OpenCores

URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [trans-decl.c] - Diff between revs 816 and 826

Only display areas with differences | Details | Blame | View Log

Rev 816	Rev 826
`/* Backend function setup`	`/* Backend function setup`
`Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010`	`Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010`
`Free Software Foundation, Inc.`	`Free Software Foundation, Inc.`
`Contributed by Paul Brook`	`Contributed by Paul Brook`

`This file is part of GCC.`	`This file is part of GCC.`

`GCC is free software; you can redistribute it and/or modify it under`	`GCC is free software; you can redistribute it and/or modify it under`
`the terms of the GNU General Public License as published by the Free`	`the terms of the GNU General Public License as published by the Free`
`Software Foundation; either version 3, or (at your option) any later`	`Software Foundation; either version 3, or (at your option) any later`
`version.`	`version.`

`GCC is distributed in the hope that it will be useful, but WITHOUT ANY`	`GCC is distributed in the hope that it will be useful, but WITHOUT ANY`
`WARRANTY; without even the implied warranty of MERCHANTABILITY or`	`WARRANTY; without even the implied warranty of MERCHANTABILITY or`
`FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License`	`FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License`
`for more details.`	`for more details.`

`You should have received a copy of the GNU General Public License`	`You should have received a copy of the GNU General Public License`
`along with GCC; see the file COPYING3. If not see`	`along with GCC; see the file COPYING3. If not see`
`<http://www.gnu.org/licenses/>. */`	`<http://www.gnu.org/licenses/>. */`

`/* trans-decl.c -- Handling of backend function and variable decls, etc */`	`/* trans-decl.c -- Handling of backend function and variable decls, etc */`

`#include "config.h"`	`#include "config.h"`
`#include "system.h"`	`#include "system.h"`
`#include "coretypes.h"`	`#include "coretypes.h"`
`#include "tree.h"`	`#include "tree.h"`
`#include "tree-dump.h"`	`#include "tree-dump.h"`
`#include "gimple.h"`	`#include "gimple.h"`
`#include "ggc.h"`	`#include "ggc.h"`
`#include "toplev.h"`	`#include "toplev.h"`
`#include "tm.h"`	`#include "tm.h"`
`#include "rtl.h"`	`#include "rtl.h"`
`#include "target.h"`	`#include "target.h"`
`#include "function.h"`	`#include "function.h"`
`#include "flags.h"`	`#include "flags.h"`
`#include "cgraph.h"`	`#include "cgraph.h"`
`#include "debug.h"`	`#include "debug.h"`
`#include "gfortran.h"`	`#include "gfortran.h"`
`#include "pointer-set.h"`	`#include "pointer-set.h"`
`#include "trans.h"`	`#include "trans.h"`
`#include "trans-types.h"`	`#include "trans-types.h"`
`#include "trans-array.h"`	`#include "trans-array.h"`
`#include "trans-const.h"`	`#include "trans-const.h"`
`/* Only for gfc_trans_code. Shouldn't need to include this. */`	`/* Only for gfc_trans_code. Shouldn't need to include this. */`
`#include "trans-stmt.h"`	`#include "trans-stmt.h"`

`#define MAX_LABEL_VALUE 99999`	`#define MAX_LABEL_VALUE 99999`


`/* Holds the result of the function if no result variable specified. */`	`/* Holds the result of the function if no result variable specified. */`

`static GTY(()) tree current_fake_result_decl;`	`static GTY(()) tree current_fake_result_decl;`
`static GTY(()) tree parent_fake_result_decl;`	`static GTY(()) tree parent_fake_result_decl;`

`static GTY(()) tree current_function_return_label;`	`static GTY(()) tree current_function_return_label;`


`/* Holds the variable DECLs for the current function. */`	`/* Holds the variable DECLs for the current function. */`

`static GTY(()) tree saved_function_decls;`	`static GTY(()) tree saved_function_decls;`
`static GTY(()) tree saved_parent_function_decls;`	`static GTY(()) tree saved_parent_function_decls;`

`static struct pointer_set_t *nonlocal_dummy_decl_pset;`	`static struct pointer_set_t *nonlocal_dummy_decl_pset;`
`static GTY(()) tree nonlocal_dummy_decls;`	`static GTY(()) tree nonlocal_dummy_decls;`

`/* Holds the variable DECLs that are locals. */`	`/* Holds the variable DECLs that are locals. */`

`static GTY(()) tree saved_local_decls;`	`static GTY(()) tree saved_local_decls;`

`/* The namespace of the module we're currently generating. Only used while`	`/* The namespace of the module we're currently generating. Only used while`
`outputting decls for module variables. Do not rely on this being set. */`	`outputting decls for module variables. Do not rely on this being set. */`

`static gfc_namespace *module_namespace;`	`static gfc_namespace *module_namespace;`


`/* List of static constructor functions. */`	`/* List of static constructor functions. */`

`tree gfc_static_ctors;`	`tree gfc_static_ctors;`


`/* Function declarations for builtin library functions. */`	`/* Function declarations for builtin library functions. */`

`tree gfor_fndecl_pause_numeric;`	`tree gfor_fndecl_pause_numeric;`
`tree gfor_fndecl_pause_string;`	`tree gfor_fndecl_pause_string;`
`tree gfor_fndecl_stop_numeric;`	`tree gfor_fndecl_stop_numeric;`
`tree gfor_fndecl_stop_string;`	`tree gfor_fndecl_stop_string;`
`tree gfor_fndecl_runtime_error;`	`tree gfor_fndecl_runtime_error;`
`tree gfor_fndecl_runtime_error_at;`	`tree gfor_fndecl_runtime_error_at;`
`tree gfor_fndecl_runtime_warning_at;`	`tree gfor_fndecl_runtime_warning_at;`
`tree gfor_fndecl_os_error;`	`tree gfor_fndecl_os_error;`
`tree gfor_fndecl_generate_error;`	`tree gfor_fndecl_generate_error;`
`tree gfor_fndecl_set_args;`	`tree gfor_fndecl_set_args;`
`tree gfor_fndecl_set_fpe;`	`tree gfor_fndecl_set_fpe;`
`tree gfor_fndecl_set_options;`	`tree gfor_fndecl_set_options;`
`tree gfor_fndecl_set_convert;`	`tree gfor_fndecl_set_convert;`
`tree gfor_fndecl_set_record_marker;`	`tree gfor_fndecl_set_record_marker;`
`tree gfor_fndecl_set_max_subrecord_length;`	`tree gfor_fndecl_set_max_subrecord_length;`
`tree gfor_fndecl_ctime;`	`tree gfor_fndecl_ctime;`
`tree gfor_fndecl_fdate;`	`tree gfor_fndecl_fdate;`
`tree gfor_fndecl_ttynam;`	`tree gfor_fndecl_ttynam;`
`tree gfor_fndecl_in_pack;`	`tree gfor_fndecl_in_pack;`
`tree gfor_fndecl_in_unpack;`	`tree gfor_fndecl_in_unpack;`
`tree gfor_fndecl_associated;`	`tree gfor_fndecl_associated;`


`/* Math functions. Many other math functions are handled in`	`/* Math functions. Many other math functions are handled in`
`trans-intrinsic.c. */`	`trans-intrinsic.c. */`

`gfc_powdecl_list gfor_fndecl_math_powi[4][3];`	`gfc_powdecl_list gfor_fndecl_math_powi[4][3];`
`tree gfor_fndecl_math_ishftc4;`	`tree gfor_fndecl_math_ishftc4;`
`tree gfor_fndecl_math_ishftc8;`	`tree gfor_fndecl_math_ishftc8;`
`tree gfor_fndecl_math_ishftc16;`	`tree gfor_fndecl_math_ishftc16;`


`/* String functions. */`	`/* String functions. */`

`tree gfor_fndecl_compare_string;`	`tree gfor_fndecl_compare_string;`
`tree gfor_fndecl_concat_string;`	`tree gfor_fndecl_concat_string;`
`tree gfor_fndecl_string_len_trim;`	`tree gfor_fndecl_string_len_trim;`
`tree gfor_fndecl_string_index;`	`tree gfor_fndecl_string_index;`
`tree gfor_fndecl_string_scan;`	`tree gfor_fndecl_string_scan;`
`tree gfor_fndecl_string_verify;`	`tree gfor_fndecl_string_verify;`
`tree gfor_fndecl_string_trim;`	`tree gfor_fndecl_string_trim;`
`tree gfor_fndecl_string_minmax;`	`tree gfor_fndecl_string_minmax;`
`tree gfor_fndecl_adjustl;`	`tree gfor_fndecl_adjustl;`
`tree gfor_fndecl_adjustr;`	`tree gfor_fndecl_adjustr;`
`tree gfor_fndecl_select_string;`	`tree gfor_fndecl_select_string;`
`tree gfor_fndecl_compare_string_char4;`	`tree gfor_fndecl_compare_string_char4;`
`tree gfor_fndecl_concat_string_char4;`	`tree gfor_fndecl_concat_string_char4;`
`tree gfor_fndecl_string_len_trim_char4;`	`tree gfor_fndecl_string_len_trim_char4;`
`tree gfor_fndecl_string_index_char4;`	`tree gfor_fndecl_string_index_char4;`
`tree gfor_fndecl_string_scan_char4;`	`tree gfor_fndecl_string_scan_char4;`
`tree gfor_fndecl_string_verify_char4;`	`tree gfor_fndecl_string_verify_char4;`
`tree gfor_fndecl_string_trim_char4;`	`tree gfor_fndecl_string_trim_char4;`
`tree gfor_fndecl_string_minmax_char4;`	`tree gfor_fndecl_string_minmax_char4;`
`tree gfor_fndecl_adjustl_char4;`	`tree gfor_fndecl_adjustl_char4;`
`tree gfor_fndecl_adjustr_char4;`	`tree gfor_fndecl_adjustr_char4;`
`tree gfor_fndecl_select_string_char4;`	`tree gfor_fndecl_select_string_char4;`


`/* Conversion between character kinds. */`	`/* Conversion between character kinds. */`
`tree gfor_fndecl_convert_char1_to_char4;`	`tree gfor_fndecl_convert_char1_to_char4;`
`tree gfor_fndecl_convert_char4_to_char1;`	`tree gfor_fndecl_convert_char4_to_char1;`


`/* Other misc. runtime library functions. */`	`/* Other misc. runtime library functions. */`

`tree gfor_fndecl_size0;`	`tree gfor_fndecl_size0;`
`tree gfor_fndecl_size1;`	`tree gfor_fndecl_size1;`
`tree gfor_fndecl_iargc;`	`tree gfor_fndecl_iargc;`
`tree gfor_fndecl_clz128;`	`tree gfor_fndecl_clz128;`
`tree gfor_fndecl_ctz128;`	`tree gfor_fndecl_ctz128;`

`/* Intrinsic functions implemented in Fortran. */`	`/* Intrinsic functions implemented in Fortran. */`
`tree gfor_fndecl_sc_kind;`	`tree gfor_fndecl_sc_kind;`
`tree gfor_fndecl_si_kind;`	`tree gfor_fndecl_si_kind;`
`tree gfor_fndecl_sr_kind;`	`tree gfor_fndecl_sr_kind;`

`/* BLAS gemm functions. */`	`/* BLAS gemm functions. */`
`tree gfor_fndecl_sgemm;`	`tree gfor_fndecl_sgemm;`
`tree gfor_fndecl_dgemm;`	`tree gfor_fndecl_dgemm;`
`tree gfor_fndecl_cgemm;`	`tree gfor_fndecl_cgemm;`
`tree gfor_fndecl_zgemm;`	`tree gfor_fndecl_zgemm;`


`static void`	`static void`
`gfc_add_decl_to_parent_function (tree decl)`	`gfc_add_decl_to_parent_function (tree decl)`
`{`	`{`
`gcc_assert (decl);`	`gcc_assert (decl);`
`DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);`	`DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);`
`DECL_NONLOCAL (decl) = 1;`	`DECL_NONLOCAL (decl) = 1;`
`TREE_CHAIN (decl) = saved_parent_function_decls;`	`TREE_CHAIN (decl) = saved_parent_function_decls;`
`saved_parent_function_decls = decl;`	`saved_parent_function_decls = decl;`
`}`	`}`

`void`	`void`
`gfc_add_decl_to_function (tree decl)`	`gfc_add_decl_to_function (tree decl)`
`{`	`{`
`gcc_assert (decl);`	`gcc_assert (decl);`
`TREE_USED (decl) = 1;`	`TREE_USED (decl) = 1;`
`DECL_CONTEXT (decl) = current_function_decl;`	`DECL_CONTEXT (decl) = current_function_decl;`
`TREE_CHAIN (decl) = saved_function_decls;`	`TREE_CHAIN (decl) = saved_function_decls;`
`saved_function_decls = decl;`	`saved_function_decls = decl;`
`}`	`}`

`static void`	`static void`
`add_decl_as_local (tree decl)`	`add_decl_as_local (tree decl)`
`{`	`{`
`gcc_assert (decl);`	`gcc_assert (decl);`
`TREE_USED (decl) = 1;`	`TREE_USED (decl) = 1;`
`DECL_CONTEXT (decl) = current_function_decl;`	`DECL_CONTEXT (decl) = current_function_decl;`
`TREE_CHAIN (decl) = saved_local_decls;`	`TREE_CHAIN (decl) = saved_local_decls;`
`saved_local_decls = decl;`	`saved_local_decls = decl;`
`}`	`}`


`/* Build a backend label declaration. Set TREE_USED for named labels.`	`/* Build a backend label declaration. Set TREE_USED for named labels.`
`The context of the label is always the current_function_decl. All`	`The context of the label is always the current_function_decl. All`
`labels are marked artificial. */`	`labels are marked artificial. */`

`tree`	`tree`
`gfc_build_label_decl (tree label_id)`	`gfc_build_label_decl (tree label_id)`
`{`	`{`
`/* 2^32 temporaries should be enough. */`	`/* 2^32 temporaries should be enough. */`
`static unsigned int tmp_num = 1;`	`static unsigned int tmp_num = 1;`
`tree label_decl;`	`tree label_decl;`
`char *label_name;`	`char *label_name;`

`if (label_id == NULL_TREE)`	`if (label_id == NULL_TREE)`
`{`	`{`
`/* Build an internal label name. */`	`/* Build an internal label name. */`
`ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);`	`ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);`
`label_id = get_identifier (label_name);`	`label_id = get_identifier (label_name);`
`}`	`}`
`else`	`else`
`label_name = NULL;`	`label_name = NULL;`

`/* Build the LABEL_DECL node. Labels have no type. */`	`/* Build the LABEL_DECL node. Labels have no type. */`
`label_decl = build_decl (input_location,`	`label_decl = build_decl (input_location,`
`LABEL_DECL, label_id, void_type_node);`	`LABEL_DECL, label_id, void_type_node);`
`DECL_CONTEXT (label_decl) = current_function_decl;`	`DECL_CONTEXT (label_decl) = current_function_decl;`
`DECL_MODE (label_decl) = VOIDmode;`	`DECL_MODE (label_decl) = VOIDmode;`

`/* We always define the label as used, even if the original source`	`/* We always define the label as used, even if the original source`
`file never references the label. We don't want all kinds of`	`file never references the label. We don't want all kinds of`
`spurious warnings for old-style Fortran code with too many`	`spurious warnings for old-style Fortran code with too many`
`labels. */`	`labels. */`
`TREE_USED (label_decl) = 1;`	`TREE_USED (label_decl) = 1;`

`DECL_ARTIFICIAL (label_decl) = 1;`	`DECL_ARTIFICIAL (label_decl) = 1;`
`return label_decl;`	`return label_decl;`
`}`	`}`


`/* Returns the return label for the current function. */`	`/* Returns the return label for the current function. */`

`tree`	`tree`
`gfc_get_return_label (void)`	`gfc_get_return_label (void)`
`{`	`{`
`char name[GFC_MAX_SYMBOL_LEN + 10];`	`char name[GFC_MAX_SYMBOL_LEN + 10];`

`if (current_function_return_label)`	`if (current_function_return_label)`
`return current_function_return_label;`	`return current_function_return_label;`

`sprintf (name, "__return_%s",`	`sprintf (name, "__return_%s",`
`IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));`	`IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));`

`current_function_return_label =`	`current_function_return_label =`
`gfc_build_label_decl (get_identifier (name));`	`gfc_build_label_decl (get_identifier (name));`

`DECL_ARTIFICIAL (current_function_return_label) = 1;`	`DECL_ARTIFICIAL (current_function_return_label) = 1;`

`return current_function_return_label;`	`return current_function_return_label;`
`}`	`}`


`/* Set the backend source location of a decl. */`	`/* Set the backend source location of a decl. */`

`void`	`void`
`gfc_set_decl_location (tree decl, locus * loc)`	`gfc_set_decl_location (tree decl, locus * loc)`
`{`	`{`
`DECL_SOURCE_LOCATION (decl) = loc->lb->location;`	`DECL_SOURCE_LOCATION (decl) = loc->lb->location;`
`}`	`}`


`/* Return the backend label declaration for a given label structure,`	`/* Return the backend label declaration for a given label structure,`
`or create it if it doesn't exist yet. */`	`or create it if it doesn't exist yet. */`

`tree`	`tree`
`gfc_get_label_decl (gfc_st_label * lp)`	`gfc_get_label_decl (gfc_st_label * lp)`
`{`	`{`
`if (lp->backend_decl)`	`if (lp->backend_decl)`
`return lp->backend_decl;`	`return lp->backend_decl;`
`else`	`else`
`{`	`{`
`char label_name[GFC_MAX_SYMBOL_LEN + 1];`	`char label_name[GFC_MAX_SYMBOL_LEN + 1];`
`tree label_decl;`	`tree label_decl;`

`/* Validate the label declaration from the front end. */`	`/* Validate the label declaration from the front end. */`
`gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);`	`gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);`

`/* Build a mangled name for the label. */`	`/* Build a mangled name for the label. */`
`sprintf (label_name, "__label_%.6d", lp->value);`	`sprintf (label_name, "__label_%.6d", lp->value);`

`/* Build the LABEL_DECL node. */`	`/* Build the LABEL_DECL node. */`
`label_decl = gfc_build_label_decl (get_identifier (label_name));`	`label_decl = gfc_build_label_decl (get_identifier (label_name));`

`/* Tell the debugger where the label came from. */`	`/* Tell the debugger where the label came from. */`
`if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */`	`if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */`
`gfc_set_decl_location (label_decl, &lp->where);`	`gfc_set_decl_location (label_decl, &lp->where);`
`else`	`else`
`DECL_ARTIFICIAL (label_decl) = 1;`	`DECL_ARTIFICIAL (label_decl) = 1;`

`/* Store the label in the label list and return the LABEL_DECL. */`	`/* Store the label in the label list and return the LABEL_DECL. */`
`lp->backend_decl = label_decl;`	`lp->backend_decl = label_decl;`
`return label_decl;`	`return label_decl;`
`}`	`}`
`}`	`}`


`/* Convert a gfc_symbol to an identifier of the same name. */`	`/* Convert a gfc_symbol to an identifier of the same name. */`

`static tree`	`static tree`
`gfc_sym_identifier (gfc_symbol * sym)`	`gfc_sym_identifier (gfc_symbol * sym)`
`{`	`{`
`if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)`	`if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)`
`return (get_identifier ("MAIN__"));`	`return (get_identifier ("MAIN__"));`
`else`	`else`
`return (get_identifier (sym->name));`	`return (get_identifier (sym->name));`
`}`	`}`


`/* Construct mangled name from symbol name. */`	`/* Construct mangled name from symbol name. */`

`static tree`	`static tree`
`gfc_sym_mangled_identifier (gfc_symbol * sym)`	`gfc_sym_mangled_identifier (gfc_symbol * sym)`
`{`	`{`
`char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];`	`char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];`

`/* Prevent the mangling of identifiers that have an assigned`	`/* Prevent the mangling of identifiers that have an assigned`
`binding label (mainly those that are bind(c)). */`	`binding label (mainly those that are bind(c)). */`
`if (sym->attr.is_bind_c == 1`	`if (sym->attr.is_bind_c == 1`
`&& sym->binding_label[0] != '\0')`	`&& sym->binding_label[0] != '\0')`
`return get_identifier(sym->binding_label);`	`return get_identifier(sym->binding_label);`

`if (sym->module == NULL)`	`if (sym->module == NULL)`
`return gfc_sym_identifier (sym);`	`return gfc_sym_identifier (sym);`
`else`	`else`
`{`	`{`
`snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);`	`snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);`
`return get_identifier (name);`	`return get_identifier (name);`
`}`	`}`
`}`	`}`


`/* Construct mangled function name from symbol name. */`	`/* Construct mangled function name from symbol name. */`

`static tree`	`static tree`
`gfc_sym_mangled_function_id (gfc_symbol * sym)`	`gfc_sym_mangled_function_id (gfc_symbol * sym)`
`{`	`{`
`int has_underscore;`	`int has_underscore;`
`char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];`	`char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];`

`/* It may be possible to simply use the binding label if it's`	`/* It may be possible to simply use the binding label if it's`
`provided, and remove the other checks. Then we could use it`	`provided, and remove the other checks. Then we could use it`
`for other things if we wished. */`	`for other things if we wished. */`
`if ((sym->attr.is_bind_c == 1 \|\| sym->attr.is_iso_c == 1) &&`	`if ((sym->attr.is_bind_c == 1 \|\| sym->attr.is_iso_c == 1) &&`
`sym->binding_label[0] != '\0')`	`sym->binding_label[0] != '\0')`
`/* use the binding label rather than the mangled name */`	`/* use the binding label rather than the mangled name */`
`return get_identifier (sym->binding_label);`	`return get_identifier (sym->binding_label);`

`if (sym->module == NULL \|\| sym->attr.proc == PROC_EXTERNAL`	`if (sym->module == NULL \|\| sym->attr.proc == PROC_EXTERNAL`
`\|\| (sym->module != NULL && (sym->attr.external`	`\|\| (sym->module != NULL && (sym->attr.external`
`\|\| sym->attr.if_source == IFSRC_IFBODY)))`	`\|\| sym->attr.if_source == IFSRC_IFBODY)))`
`{`	`{`
`/* Main program is mangled into MAIN__. */`	`/* Main program is mangled into MAIN__. */`
`if (sym->attr.is_main_program)`	`if (sym->attr.is_main_program)`
`return get_identifier ("MAIN__");`	`return get_identifier ("MAIN__");`

`/* Intrinsic procedures are never mangled. */`	`/* Intrinsic procedures are never mangled. */`
`if (sym->attr.proc == PROC_INTRINSIC)`	`if (sym->attr.proc == PROC_INTRINSIC)`
`return get_identifier (sym->name);`	`return get_identifier (sym->name);`

`if (gfc_option.flag_underscoring)`	`if (gfc_option.flag_underscoring)`
`{`	`{`
`has_underscore = strchr (sym->name, '_') != 0;`	`has_underscore = strchr (sym->name, '_') != 0;`
`if (gfc_option.flag_second_underscore && has_underscore)`	`if (gfc_option.flag_second_underscore && has_underscore)`
`snprintf (name, sizeof name, "%s__", sym->name);`	`snprintf (name, sizeof name, "%s__", sym->name);`
`else`	`else`
`snprintf (name, sizeof name, "%s_", sym->name);`	`snprintf (name, sizeof name, "%s_", sym->name);`
`return get_identifier (name);`	`return get_identifier (name);`
`}`	`}`
`else`	`else`
`return get_identifier (sym->name);`	`return get_identifier (sym->name);`
`}`	`}`
`else`	`else`
`{`	`{`
`snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);`	`snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);`
`return get_identifier (name);`	`return get_identifier (name);`
`}`	`}`
`}`	`}`


`void`	`void`
`gfc_set_decl_assembler_name (tree decl, tree name)`	`gfc_set_decl_assembler_name (tree decl, tree name)`
`{`	`{`
`tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);`	`tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);`
`SET_DECL_ASSEMBLER_NAME (decl, target_mangled);`	`SET_DECL_ASSEMBLER_NAME (decl, target_mangled);`
`}`	`}`


`/* Returns true if a variable of specified size should go on the stack. */`	`/* Returns true if a variable of specified size should go on the stack. */`

`int`	`int`
`gfc_can_put_var_on_stack (tree size)`	`gfc_can_put_var_on_stack (tree size)`
`{`	`{`
`unsigned HOST_WIDE_INT low;`	`unsigned HOST_WIDE_INT low;`

`if (!INTEGER_CST_P (size))`	`if (!INTEGER_CST_P (size))`
`return 0;`	`return 0;`

`if (gfc_option.flag_max_stack_var_size < 0)`	`if (gfc_option.flag_max_stack_var_size < 0)`
`return 1;`	`return 1;`

`if (TREE_INT_CST_HIGH (size) != 0)`	`if (TREE_INT_CST_HIGH (size) != 0)`
`return 0;`	`return 0;`

`low = TREE_INT_CST_LOW (size);`	`low = TREE_INT_CST_LOW (size);`
`if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)`	`if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)`
`return 0;`	`return 0;`

`/* TODO: Set a per-function stack size limit. */`	`/* TODO: Set a per-function stack size limit. */`

`return 1;`	`return 1;`
`}`	`}`


`/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to`	`/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to`
`an expression involving its corresponding pointer. There are`	`an expression involving its corresponding pointer. There are`
`2 cases; one for variable size arrays, and one for everything else,`	`2 cases; one for variable size arrays, and one for everything else,`
`because variable-sized arrays require one fewer level of`	`because variable-sized arrays require one fewer level of`
`indirection. */`	`indirection. */`

`static void`	`static void`
`gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)`	`gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)`
`{`	`{`
`tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);`	`tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);`
`tree value;`	`tree value;`

`/* Parameters need to be dereferenced. */`	`/* Parameters need to be dereferenced. */`
`if (sym->cp_pointer->attr.dummy)`	`if (sym->cp_pointer->attr.dummy)`
`ptr_decl = build_fold_indirect_ref_loc (input_location,`	`ptr_decl = build_fold_indirect_ref_loc (input_location,`
`ptr_decl);`	`ptr_decl);`

`/* Check to see if we're dealing with a variable-sized array. */`	`/* Check to see if we're dealing with a variable-sized array. */`
`if (sym->attr.dimension`	`if (sym->attr.dimension`
`&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)`	`&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)`
`{`	`{`
`/* These decls will be dereferenced later, so we don't dereference`	`/* These decls will be dereferenced later, so we don't dereference`
`them here. */`	`them here. */`
`value = convert (TREE_TYPE (decl), ptr_decl);`	`value = convert (TREE_TYPE (decl), ptr_decl);`
`}`	`}`
`else`	`else`
`{`	`{`
`ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),`	`ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),`
`ptr_decl);`	`ptr_decl);`
`value = build_fold_indirect_ref_loc (input_location,`	`value = build_fold_indirect_ref_loc (input_location,`
`ptr_decl);`	`ptr_decl);`
`}`	`}`

`SET_DECL_VALUE_EXPR (decl, value);`	`SET_DECL_VALUE_EXPR (decl, value);`
`DECL_HAS_VALUE_EXPR_P (decl) = 1;`	`DECL_HAS_VALUE_EXPR_P (decl) = 1;`
`GFC_DECL_CRAY_POINTEE (decl) = 1;`	`GFC_DECL_CRAY_POINTEE (decl) = 1;`
`/* This is a fake variable just for debugging purposes. */`	`/* This is a fake variable just for debugging purposes. */`
`TREE_ASM_WRITTEN (decl) = 1;`	`TREE_ASM_WRITTEN (decl) = 1;`
`}`	`}`


`/* Finish processing of a declaration without an initial value. */`	`/* Finish processing of a declaration without an initial value. */`

`static void`	`static void`
`gfc_finish_decl (tree decl)`	`gfc_finish_decl (tree decl)`
`{`	`{`
`gcc_assert (TREE_CODE (decl) == PARM_DECL`	`gcc_assert (TREE_CODE (decl) == PARM_DECL`
`\|\| DECL_INITIAL (decl) == NULL_TREE);`	`\|\| DECL_INITIAL (decl) == NULL_TREE);`

`if (TREE_CODE (decl) != VAR_DECL)`	`if (TREE_CODE (decl) != VAR_DECL)`
`return;`	`return;`

`if (DECL_SIZE (decl) == NULL_TREE`	`if (DECL_SIZE (decl) == NULL_TREE`
`&& TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)`	`&& TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)`
`layout_decl (decl, 0);`	`layout_decl (decl, 0);`

`/* A few consistency checks. */`	`/* A few consistency checks. */`
`/* A static variable with an incomplete type is an error if it is`	`/* A static variable with an incomplete type is an error if it is`
`initialized. Also if it is not file scope. Otherwise, let it`	`initialized. Also if it is not file scope. Otherwise, let it`
through, but if it is not `extern' then it may cause an error	through, but if it is not `extern' then it may cause an error
`message later. */`	`message later. */`
`/* An automatic variable with an incomplete type is an error. */`	`/* An automatic variable with an incomplete type is an error. */`

`/* We should know the storage size. */`	`/* We should know the storage size. */`
`gcc_assert (DECL_SIZE (decl) != NULL_TREE`	`gcc_assert (DECL_SIZE (decl) != NULL_TREE`
`\|\| (TREE_STATIC (decl)`	`\|\| (TREE_STATIC (decl)`
`? (!DECL_INITIAL (decl) \|\| !DECL_CONTEXT (decl))`	`? (!DECL_INITIAL (decl) \|\| !DECL_CONTEXT (decl))`
`: DECL_EXTERNAL (decl)));`	`: DECL_EXTERNAL (decl)));`

`/* The storage size should be constant. */`	`/* The storage size should be constant. */`
`gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))`	`gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))`
`\|\| !DECL_SIZE (decl)`	`\|\| !DECL_SIZE (decl)`
`\|\| TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);`	`\|\| TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);`
`}`	`}`


`/* Apply symbol attributes to a variable, and add it to the function scope. */`	`/* Apply symbol attributes to a variable, and add it to the function scope. */`

`static void`	`static void`
`gfc_finish_var_decl (tree decl, gfc_symbol * sym)`	`gfc_finish_var_decl (tree decl, gfc_symbol * sym)`
`{`	`{`
`tree new_type;`	`tree new_type;`
`/* TREE_ADDRESSABLE means the address of this variable is actually needed.`	`/* TREE_ADDRESSABLE means the address of this variable is actually needed.`
`This is the equivalent of the TARGET variables.`	`This is the equivalent of the TARGET variables.`
`We also need to set this if the variable is passed by reference in a`	`We also need to set this if the variable is passed by reference in a`
`CALL statement. */`	`CALL statement. */`

`/* Set DECL_VALUE_EXPR for Cray Pointees. */`	`/* Set DECL_VALUE_EXPR for Cray Pointees. */`
`if (sym->attr.cray_pointee)`	`if (sym->attr.cray_pointee)`
`gfc_finish_cray_pointee (decl, sym);`	`gfc_finish_cray_pointee (decl, sym);`

`if (sym->attr.target)`	`if (sym->attr.target)`
`TREE_ADDRESSABLE (decl) = 1;`	`TREE_ADDRESSABLE (decl) = 1;`
`/* If it wasn't used we wouldn't be getting it. */`	`/* If it wasn't used we wouldn't be getting it. */`
`TREE_USED (decl) = 1;`	`TREE_USED (decl) = 1;`

`/* Chain this decl to the pending declarations. Don't do pushdecl()`	`/* Chain this decl to the pending declarations. Don't do pushdecl()`
`because this would add them to the current scope rather than the`	`because this would add them to the current scope rather than the`
`function scope. */`	`function scope. */`
`if (current_function_decl != NULL_TREE)`	`if (current_function_decl != NULL_TREE)`
`{`	`{`
`if (sym->ns->proc_name->backend_decl == current_function_decl`	`if (sym->ns->proc_name->backend_decl == current_function_decl`
`\|\| sym->result == sym)`	`\|\| sym->result == sym)`
`gfc_add_decl_to_function (decl);`	`gfc_add_decl_to_function (decl);`
`else if (sym->ns->proc_name->attr.flavor == FL_LABEL)`	`else if (sym->ns->proc_name->attr.flavor == FL_LABEL)`
`/* This is a BLOCK construct. */`	`/* This is a BLOCK construct. */`
`add_decl_as_local (decl);`	`add_decl_as_local (decl);`
`else`	`else`
`gfc_add_decl_to_parent_function (decl);`	`gfc_add_decl_to_parent_function (decl);`
`}`	`}`

`if (sym->attr.cray_pointee)`	`if (sym->attr.cray_pointee)`
`return;`	`return;`

`if(sym->attr.is_bind_c == 1)`	`if(sym->attr.is_bind_c == 1)`
`{`	`{`
`/* We need to put variables that are bind(c) into the common`	`/* We need to put variables that are bind(c) into the common`
`segment of the object file, because this is what C would do.`	`segment of the object file, because this is what C would do.`
`gfortran would typically put them in either the BSS or`	`gfortran would typically put them in either the BSS or`
`initialized data segments, and only mark them as common if`	`initialized data segments, and only mark them as common if`
`they were part of common blocks. However, if they are not put`	`they were part of common blocks. However, if they are not put`
`into common space, then C cannot initialize global Fortran`	`into common space, then C cannot initialize global Fortran`
`variables that it interoperates with and the draft says that`	`variables that it interoperates with and the draft says that`
`either Fortran or C should be able to initialize it (but not`	`either Fortran or C should be able to initialize it (but not`
`both, of course.) (J3/04-007, section 15.3). */`	`both, of course.) (J3/04-007, section 15.3). */`
`TREE_PUBLIC(decl) = 1;`	`TREE_PUBLIC(decl) = 1;`
`DECL_COMMON(decl) = 1;`	`DECL_COMMON(decl) = 1;`
`}`	`}`

`/* If a variable is USE associated, it's always external. */`	`/* If a variable is USE associated, it's always external. */`
`if (sym->attr.use_assoc)`	`if (sym->attr.use_assoc)`
`{`	`{`
`DECL_EXTERNAL (decl) = 1;`	`DECL_EXTERNAL (decl) = 1;`
`TREE_PUBLIC (decl) = 1;`	`TREE_PUBLIC (decl) = 1;`
`}`	`}`
`else if (sym->module && !sym->attr.result && !sym->attr.dummy)`	`else if (sym->module && !sym->attr.result && !sym->attr.dummy)`
`{`	`{`
`/* TODO: Don't set sym->module for result or dummy variables. */`	`/* TODO: Don't set sym->module for result or dummy variables. */`
`gcc_assert (current_function_decl == NULL_TREE \|\| sym->result == sym);`	`gcc_assert (current_function_decl == NULL_TREE \|\| sym->result == sym);`
`/* This is the declaration of a module variable. */`	`/* This is the declaration of a module variable. */`
`TREE_PUBLIC (decl) = 1;`	`TREE_PUBLIC (decl) = 1;`
`TREE_STATIC (decl) = 1;`	`TREE_STATIC (decl) = 1;`
`}`	`}`

`/* Derived types are a bit peculiar because of the possibility of`	`/* Derived types are a bit peculiar because of the possibility of`
`a default initializer; this must be applied each time the variable`	`a default initializer; this must be applied each time the variable`
`comes into scope it therefore need not be static. These variables`	`comes into scope it therefore need not be static. These variables`
`are SAVE_NONE but have an initializer. Otherwise explicitly`	`are SAVE_NONE but have an initializer. Otherwise explicitly`
`initialized variables are SAVE_IMPLICIT and explicitly saved are`	`initialized variables are SAVE_IMPLICIT and explicitly saved are`
`SAVE_EXPLICIT. */`	`SAVE_EXPLICIT. */`
`if (!sym->attr.use_assoc`	`if (!sym->attr.use_assoc`
`&& (sym->attr.save != SAVE_NONE \|\| sym->attr.data`	`&& (sym->attr.save != SAVE_NONE \|\| sym->attr.data`
`\|\| (sym->value && sym->ns->proc_name->attr.is_main_program)))`	`\|\| (sym->value && sym->ns->proc_name->attr.is_main_program)))`
`TREE_STATIC (decl) = 1;`	`TREE_STATIC (decl) = 1;`

`if (sym->attr.volatile_)`	`if (sym->attr.volatile_)`
`{`	`{`
`TREE_THIS_VOLATILE (decl) = 1;`	`TREE_THIS_VOLATILE (decl) = 1;`
`new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);`	`new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);`
`TREE_TYPE (decl) = new_type;`	`TREE_TYPE (decl) = new_type;`
`}`	`}`

`/* Keep variables larger than max-stack-var-size off stack. */`	`/* Keep variables larger than max-stack-var-size off stack. */`
`if (!sym->ns->proc_name->attr.recursive`	`if (!sym->ns->proc_name->attr.recursive`
`&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))`	`&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))`
`&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))`	`&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))`
`/* Put variable length auto array pointers always into stack. */`	`/* Put variable length auto array pointers always into stack. */`
`&& (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE`	`&& (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE`
`\|\| sym->attr.dimension == 0`	`\|\| sym->attr.dimension == 0`
`\|\| sym->as->type != AS_EXPLICIT`	`\|\| sym->as->type != AS_EXPLICIT`
`\|\| sym->attr.pointer`	`\|\| sym->attr.pointer`
`\|\| sym->attr.allocatable)`	`\|\| sym->attr.allocatable)`
`&& !DECL_ARTIFICIAL (decl))`	`&& !DECL_ARTIFICIAL (decl))`
`TREE_STATIC (decl) = 1;`	`TREE_STATIC (decl) = 1;`

`/* Handle threadprivate variables. */`	`/* Handle threadprivate variables. */`
`if (sym->attr.threadprivate`	`if (sym->attr.threadprivate`
`&& (TREE_STATIC (decl) \|\| DECL_EXTERNAL (decl)))`	`&& (TREE_STATIC (decl) \|\| DECL_EXTERNAL (decl)))`
`DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);`	`DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);`

`if (!sym->attr.target`	`if (!sym->attr.target`
`&& !sym->attr.pointer`	`&& !sym->attr.pointer`
`&& !sym->attr.cray_pointee`	`&& !sym->attr.cray_pointee`
`&& !sym->attr.proc_pointer)`	`&& !sym->attr.proc_pointer)`
`DECL_RESTRICTED_P (decl) = 1;`	`DECL_RESTRICTED_P (decl) = 1;`
`}`	`}`


`/* Allocate the lang-specific part of a decl. */`	`/* Allocate the lang-specific part of a decl. */`

`void`	`void`
`gfc_allocate_lang_decl (tree decl)`	`gfc_allocate_lang_decl (tree decl)`
`{`	`{`
`DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)`	`DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)`
`ggc_alloc_cleared (sizeof (struct lang_decl));`	`ggc_alloc_cleared (sizeof (struct lang_decl));`
`}`	`}`

`/* Remember a symbol to generate initialization/cleanup code at function`	`/* Remember a symbol to generate initialization/cleanup code at function`
`entry/exit. */`	`entry/exit. */`

`static void`	`static void`
`gfc_defer_symbol_init (gfc_symbol * sym)`	`gfc_defer_symbol_init (gfc_symbol * sym)`
`{`	`{`
`gfc_symbol *p;`	`gfc_symbol *p;`
`gfc_symbol *last;`	`gfc_symbol *last;`
`gfc_symbol *head;`	`gfc_symbol *head;`

`/* Don't add a symbol twice. */`	`/* Don't add a symbol twice. */`
`if (sym->tlink)`	`if (sym->tlink)`
`return;`	`return;`

`last = head = sym->ns->proc_name;`	`last = head = sym->ns->proc_name;`
`p = last->tlink;`	`p = last->tlink;`

`/* Make sure that setup code for dummy variables which are used in the`	`/* Make sure that setup code for dummy variables which are used in the`
`setup of other variables is generated first. */`	`setup of other variables is generated first. */`
`if (sym->attr.dummy)`	`if (sym->attr.dummy)`
`{`	`{`
`/* Find the first dummy arg seen after us, or the first non-dummy arg.`	`/* Find the first dummy arg seen after us, or the first non-dummy arg.`
`This is a circular list, so don't go past the head. */`	`This is a circular list, so don't go past the head. */`
`while (p != head`	`while (p != head`
`&& (!p->attr.dummy \|\| p->dummy_order > sym->dummy_order))`	`&& (!p->attr.dummy \|\| p->dummy_order > sym->dummy_order))`
`{`	`{`
`last = p;`	`last = p;`
`p = p->tlink;`	`p = p->tlink;`
`}`	`}`
`}`	`}`
`/* Insert in between last and p. */`	`/* Insert in between last and p. */`
`last->tlink = sym;`	`last->tlink = sym;`
`sym->tlink = p;`	`sym->tlink = p;`
`}`	`}`


`/* Create an array index type variable with function scope. */`	`/* Create an array index type variable with function scope. */`

`static tree`	`static tree`
`create_index_var (const char * pfx, int nest)`	`create_index_var (const char * pfx, int nest)`
`{`	`{`
`tree decl;`	`tree decl;`

`decl = gfc_create_var_np (gfc_array_index_type, pfx);`	`decl = gfc_create_var_np (gfc_array_index_type, pfx);`
`if (nest)`	`if (nest)`
`gfc_add_decl_to_parent_function (decl);`	`gfc_add_decl_to_parent_function (decl);`
`else`	`else`
`gfc_add_decl_to_function (decl);`	`gfc_add_decl_to_function (decl);`
`return decl;`	`return decl;`
`}`	`}`


`/* Create variables to hold all the non-constant bits of info for a`	`/* Create variables to hold all the non-constant bits of info for a`
`descriptorless array. Remember these in the lang-specific part of the`	`descriptorless array. Remember these in the lang-specific part of the`
`type. */`	`type. */`

`static void`	`static void`
`gfc_build_qualified_array (tree decl, gfc_symbol * sym)`	`gfc_build_qualified_array (tree decl, gfc_symbol * sym)`
`{`	`{`
`tree type;`	`tree type;`
`int dim;`	`int dim;`
`int nest;`	`int nest;`

`type = TREE_TYPE (decl);`	`type = TREE_TYPE (decl);`

`/* We just use the descriptor, if there is one. */`	`/* We just use the descriptor, if there is one. */`
`if (GFC_DESCRIPTOR_TYPE_P (type))`	`if (GFC_DESCRIPTOR_TYPE_P (type))`
`return;`	`return;`

`gcc_assert (GFC_ARRAY_TYPE_P (type));`	`gcc_assert (GFC_ARRAY_TYPE_P (type));`
`nest = (sym->ns->proc_name->backend_decl != current_function_decl)`	`nest = (sym->ns->proc_name->backend_decl != current_function_decl)`
`&& !sym->attr.contained;`	`&& !sym->attr.contained;`

`for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)`	`for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)`
`{`	`{`
`if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)`	`if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)`
`{`	`{`
`GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);`	`GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);`
`TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;`	`TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;`
`}`	`}`
`/* Don't try to use the unknown bound for assumed shape arrays. */`	`/* Don't try to use the unknown bound for assumed shape arrays. */`
`if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE`	`if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE`
`&& (sym->as->type != AS_ASSUMED_SIZE`	`&& (sym->as->type != AS_ASSUMED_SIZE`
`\|\| dim < GFC_TYPE_ARRAY_RANK (type) - 1))`	`\|\| dim < GFC_TYPE_ARRAY_RANK (type) - 1))`
`{`	`{`
`GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);`	`GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);`
`TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;`	`TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;`
`}`	`}`

`if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)`	`if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)`
`{`	`{`
`GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);`	`GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);`
`TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;`	`TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;`
`}`	`}`
`}`	`}`
`if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)`	`if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)`
`{`	`{`
`GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,`	`GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,`
`"offset");`	`"offset");`
`TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;`	`TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;`

`if (nest)`	`if (nest)`
`gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));`	`gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));`
`else`	`else`
`gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));`	`gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));`
`}`	`}`

`if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE`	`if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE`
`&& sym->as->type != AS_ASSUMED_SIZE)`	`&& sym->as->type != AS_ASSUMED_SIZE)`
`{`	`{`
`GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);`	`GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);`
`TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;`	`TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;`
`}`	`}`

`if (POINTER_TYPE_P (type))`	`if (POINTER_TYPE_P (type))`
`{`	`{`
`gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));`	`gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));`
`gcc_assert (TYPE_LANG_SPECIFIC (type)`	`gcc_assert (TYPE_LANG_SPECIFIC (type)`
`== TYPE_LANG_SPECIFIC (TREE_TYPE (type)));`	`== TYPE_LANG_SPECIFIC (TREE_TYPE (type)));`
`type = TREE_TYPE (type);`	`type = TREE_TYPE (type);`
`}`	`}`

`if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))`	`if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))`
`{`	`{`
`tree size, range;`	`tree size, range;`

`size = fold_build2 (MINUS_EXPR, gfc_array_index_type,`	`size = fold_build2 (MINUS_EXPR, gfc_array_index_type,`
`GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);`	`GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);`
`range = build_range_type (gfc_array_index_type, gfc_index_zero_node,`	`range = build_range_type (gfc_array_index_type, gfc_index_zero_node,`
`size);`	`size);`
`TYPE_DOMAIN (type) = range;`	`TYPE_DOMAIN (type) = range;`
`layout_type (type);`	`layout_type (type);`
`}`	`}`

`if (TYPE_NAME (type) != NULL_TREE`	`if (TYPE_NAME (type) != NULL_TREE`
`&& GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE`	`&& GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE`
`&& TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)`	`&& TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)`
`{`	`{`
`tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));`	`tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));`

`for (dim = 0; dim < sym->as->rank - 1; dim++)`	`for (dim = 0; dim < sym->as->rank - 1; dim++)`
`{`	`{`
`gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);`	`gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);`
`gtype = TREE_TYPE (gtype);`	`gtype = TREE_TYPE (gtype);`
`}`	`}`
`gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);`	`gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);`
`if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)`	`if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)`
`TYPE_NAME (type) = NULL_TREE;`	`TYPE_NAME (type) = NULL_TREE;`
`}`	`}`

`if (TYPE_NAME (type) == NULL_TREE)`	`if (TYPE_NAME (type) == NULL_TREE)`
`{`	`{`
`tree gtype = TREE_TYPE (type), rtype, type_decl;`	`tree gtype = TREE_TYPE (type), rtype, type_decl;`

`for (dim = sym->as->rank - 1; dim >= 0; dim--)`	`for (dim = sym->as->rank - 1; dim >= 0; dim--)`
`{`	`{`
`rtype = build_range_type (gfc_array_index_type,`	`rtype = build_range_type (gfc_array_index_type,`
`GFC_TYPE_ARRAY_LBOUND (type, dim),`	`GFC_TYPE_ARRAY_LBOUND (type, dim),`
`GFC_TYPE_ARRAY_UBOUND (type, dim));`	`GFC_TYPE_ARRAY_UBOUND (type, dim));`
`gtype = build_array_type (gtype, rtype);`	`gtype = build_array_type (gtype, rtype);`
`/* Ensure the bound variables aren't optimized out at -O0. */`	`/* Ensure the bound variables aren't optimized out at -O0. */`
`if (!optimize)`	`if (!optimize)`
`{`	`{`
`if (GFC_TYPE_ARRAY_LBOUND (type, dim)`	`if (GFC_TYPE_ARRAY_LBOUND (type, dim)`
`&& TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)`	`&& TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)`
`DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;`	`DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;`
`if (GFC_TYPE_ARRAY_UBOUND (type, dim)`	`if (GFC_TYPE_ARRAY_UBOUND (type, dim)`
`&& TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)`	`&& TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)`
`DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;`	`DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;`
`}`	`}`
`}`	`}`
`TYPE_NAME (type) = type_decl = build_decl (input_location,`	`TYPE_NAME (type) = type_decl = build_decl (input_location,`
`TYPE_DECL, NULL, gtype);`	`TYPE_DECL, NULL, gtype);`
`DECL_ORIGINAL_TYPE (type_decl) = gtype;`	`DECL_ORIGINAL_TYPE (type_decl) = gtype;`
`}`	`}`
`}`	`}`


`/* For some dummy arguments we don't use the actual argument directly.`	`/* For some dummy arguments we don't use the actual argument directly.`
`Instead we create a local decl and use that. This allows us to perform`	`Instead we create a local decl and use that. This allows us to perform`
`initialization, and construct full type information. */`	`initialization, and construct full type information. */`

`static tree`	`static tree`
`gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)`	`gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)`
`{`	`{`
`tree decl;`	`tree decl;`
`tree type;`	`tree type;`
`gfc_array_spec *as;`	`gfc_array_spec *as;`
`char *name;`	`char *name;`
`gfc_packed packed;`	`gfc_packed packed;`
`int n;`	`int n;`
`bool known_size;`	`bool known_size;`

`if (sym->attr.pointer \|\| sym->attr.allocatable)`	`if (sym->attr.pointer \|\| sym->attr.allocatable)`
`return dummy;`	`return dummy;`

`/* Add to list of variables if not a fake result variable. */`	`/* Add to list of variables if not a fake result variable. */`
`if (sym->attr.result \|\| sym->attr.dummy)`	`if (sym->attr.result \|\| sym->attr.dummy)`
`gfc_defer_symbol_init (sym);`	`gfc_defer_symbol_init (sym);`

`type = TREE_TYPE (dummy);`	`type = TREE_TYPE (dummy);`
`gcc_assert (TREE_CODE (dummy) == PARM_DECL`	`gcc_assert (TREE_CODE (dummy) == PARM_DECL`
`&& POINTER_TYPE_P (type));`	`&& POINTER_TYPE_P (type));`

`/* Do we know the element size? */`	`/* Do we know the element size? */`
`known_size = sym->ts.type != BT_CHARACTER`	`known_size = sym->ts.type != BT_CHARACTER`
`\|\| INTEGER_CST_P (sym->ts.u.cl->backend_decl);`	`\|\| INTEGER_CST_P (sym->ts.u.cl->backend_decl);`

`if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))`	`if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))`
`{`	`{`
`/* For descriptorless arrays with known element size the actual`	`/* For descriptorless arrays with known element size the actual`
`argument is sufficient. */`	`argument is sufficient. */`
`gcc_assert (GFC_ARRAY_TYPE_P (type));`	`gcc_assert (GFC_ARRAY_TYPE_P (type));`
`gfc_build_qualified_array (dummy, sym);`	`gfc_build_qualified_array (dummy, sym);`
`return dummy;`	`return dummy;`
`}`	`}`

`type = TREE_TYPE (type);`	`type = TREE_TYPE (type);`
`if (GFC_DESCRIPTOR_TYPE_P (type))`	`if (GFC_DESCRIPTOR_TYPE_P (type))`
`{`	`{`
`/* Create a descriptorless array pointer. */`	`/* Create a descriptorless array pointer. */`
`as = sym->as;`	`as = sym->as;`
`packed = PACKED_NO;`	`packed = PACKED_NO;`

`/* Even when -frepack-arrays is used, symbols with TARGET attribute`	`/* Even when -frepack-arrays is used, symbols with TARGET attribute`
`are not repacked. */`	`are not repacked. */`
`if (!gfc_option.flag_repack_arrays \|\| sym->attr.target)`	`if (!gfc_option.flag_repack_arrays \|\| sym->attr.target)`
`{`	`{`
`if (as->type == AS_ASSUMED_SIZE)`	`if (as->type == AS_ASSUMED_SIZE)`
`packed = PACKED_FULL;`	`packed = PACKED_FULL;`
`}`	`}`
`else`	`else`
`{`	`{`
`if (as->type == AS_EXPLICIT)`	`if (as->type == AS_EXPLICIT)`
`{`	`{`
`packed = PACKED_FULL;`	`packed = PACKED_FULL;`
`for (n = 0; n < as->rank; n++)`	`for (n = 0; n < as->rank; n++)`
`{`	`{`
`if (!(as->upper[n]`	`if (!(as->upper[n]`
`&& as->lower[n]`	`&& as->lower[n]`
`&& as->upper[n]->expr_type == EXPR_CONSTANT`	`&& as->upper[n]->expr_type == EXPR_CONSTANT`
`&& as->lower[n]->expr_type == EXPR_CONSTANT))`	`&& as->lower[n]->expr_type == EXPR_CONSTANT))`
`packed = PACKED_PARTIAL;`	`packed = PACKED_PARTIAL;`
`}`	`}`
`}`	`}`
`else`	`else`
`packed = PACKED_PARTIAL;`	`packed = PACKED_PARTIAL;`
`}`	`}`

`type = gfc_typenode_for_spec (&sym->ts);`	`type = gfc_typenode_for_spec (&sym->ts);`
`type = gfc_get_nodesc_array_type (type, sym->as, packed,`	`type = gfc_get_nodesc_array_type (type, sym->as, packed,`
`!sym->attr.target);`	`!sym->attr.target);`
`}`	`}`
`else`	`else`
`{`	`{`
`/* We now have an expression for the element size, so create a fully`	`/* We now have an expression for the element size, so create a fully`
`qualified type. Reset sym->backend decl or this will just return the`	`qualified type. Reset sym->backend decl or this will just return the`
`old type. */`	`old type. */`
`DECL_ARTIFICIAL (sym->backend_decl) = 1;`	`DECL_ARTIFICIAL (sym->backend_decl) = 1;`
`sym->backend_decl = NULL_TREE;`	`sym->backend_decl = NULL_TREE;`
`type = gfc_sym_type (sym);`	`type = gfc_sym_type (sym);`
`packed = PACKED_FULL;`	`packed = PACKED_FULL;`
`}`	`}`

`ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);`	`ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);`
`decl = build_decl (input_location,`	`decl = build_decl (input_location,`
`VAR_DECL, get_identifier (name), type);`	`VAR_DECL, get_identifier (name), type);`

`DECL_ARTIFICIAL (decl) = 1;`	`DECL_ARTIFICIAL (decl) = 1;`
`TREE_PUBLIC (decl) = 0;`	`TREE_PUBLIC (decl) = 0;`
`TREE_STATIC (decl) = 0;`	`TREE_STATIC (decl) = 0;`
`DECL_EXTERNAL (decl) = 0;`	`DECL_EXTERNAL (decl) = 0;`

`/* We should never get deferred shape arrays here. We used to because of`	`/* We should never get deferred shape arrays here. We used to because of`
`frontend bugs. */`	`frontend bugs. */`
`gcc_assert (sym->as->type != AS_DEFERRED);`	`gcc_assert (sym->as->type != AS_DEFERRED);`

`if (packed == PACKED_PARTIAL)`	`if (packed == PACKED_PARTIAL)`
`GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;`	`GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;`
`else if (packed == PACKED_FULL)`	`else if (packed == PACKED_FULL)`
`GFC_DECL_PACKED_ARRAY (decl) = 1;`	`GFC_DECL_PACKED_ARRAY (decl) = 1;`

`gfc_build_qualified_array (decl, sym);`	`gfc_build_qualified_array (decl, sym);`

`if (DECL_LANG_SPECIFIC (dummy))`	`if (DECL_LANG_SPECIFIC (dummy))`
`DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);`	`DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);`
`else`	`else`
`gfc_allocate_lang_decl (decl);`	`gfc_allocate_lang_decl (decl);`

`GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;`	`GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;`

`if (sym->ns->proc_name->backend_decl == current_function_decl`	`if (sym->ns->proc_name->backend_decl == current_function_decl`
`\|\| sym->attr.contained)`	`\|\| sym->attr.contained)`
`gfc_add_decl_to_function (decl);`	`gfc_add_decl_to_function (decl);`
`else`	`else`
`gfc_add_decl_to_parent_function (decl);`	`gfc_add_decl_to_parent_function (decl);`

`return decl;`	`return decl;`
`}`	`}`

`/* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained`	`/* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained`
`function add a VAR_DECL to the current function with DECL_VALUE_EXPR`	`function add a VAR_DECL to the current function with DECL_VALUE_EXPR`
`pointing to the artificial variable for debug info purposes. */`	`pointing to the artificial variable for debug info purposes. */`

`static void`	`static void`
`gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)`	`gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)`
`{`	`{`
`tree decl, dummy;`	`tree decl, dummy;`

`if (! nonlocal_dummy_decl_pset)`	`if (! nonlocal_dummy_decl_pset)`
`nonlocal_dummy_decl_pset = pointer_set_create ();`	`nonlocal_dummy_decl_pset = pointer_set_create ();`

`if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))`	`if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))`
`return;`	`return;`

`dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);`	`dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);`
`decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),`	`decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),`
`TREE_TYPE (sym->backend_decl));`	`TREE_TYPE (sym->backend_decl));`
`DECL_ARTIFICIAL (decl) = 0;`	`DECL_ARTIFICIAL (decl) = 0;`
`TREE_USED (decl) = 1;`	`TREE_USED (decl) = 1;`
`TREE_PUBLIC (decl) = 0;`	`TREE_PUBLIC (decl) = 0;`
`TREE_STATIC (decl) = 0;`	`TREE_STATIC (decl) = 0;`
`DECL_EXTERNAL (decl) = 0;`	`DECL_EXTERNAL (decl) = 0;`
`if (DECL_BY_REFERENCE (dummy))`	`if (DECL_BY_REFERENCE (dummy))`
`DECL_BY_REFERENCE (decl) = 1;`	`DECL_BY_REFERENCE (decl) = 1;`
`DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);`	`DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);`
`SET_DECL_VALUE_EXPR (decl, sym->backend_decl);`	`SET_DECL_VALUE_EXPR (decl, sym->backend_decl);`
`DECL_HAS_VALUE_EXPR_P (decl) = 1;`	`DECL_HAS_VALUE_EXPR_P (decl) = 1;`
`DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);`	`DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);`
`TREE_CHAIN (decl) = nonlocal_dummy_decls;`	`TREE_CHAIN (decl) = nonlocal_dummy_decls;`
`nonlocal_dummy_decls = decl;`	`nonlocal_dummy_decls = decl;`
`}`	`}`

`/* Return a constant or a variable to use as a string length. Does not`	`/* Return a constant or a variable to use as a string length. Does not`
`add the decl to the current scope. */`	`add the decl to the current scope. */`

`static tree`	`static tree`
`gfc_create_string_length (gfc_symbol * sym)`	`gfc_create_string_length (gfc_symbol * sym)`
`{`	`{`
`gcc_assert (sym->ts.u.cl);`	`gcc_assert (sym->ts.u.cl);`
`gfc_conv_const_charlen (sym->ts.u.cl);`	`gfc_conv_const_charlen (sym->ts.u.cl);`

`if (sym->ts.u.cl->backend_decl == NULL_TREE)`	`if (sym->ts.u.cl->backend_decl == NULL_TREE)`
`{`	`{`
`tree length;`	`tree length;`
`char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];`	`char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];`

`/* Also prefix the mangled name. */`	`/* Also prefix the mangled name. */`
`strcpy (&name[1], sym->name);`	`strcpy (&name[1], sym->name);`
`name[0] = '.';`	`name[0] = '.';`
`length = build_decl (input_location,`	`length = build_decl (input_location,`
`VAR_DECL, get_identifier (name),`	`VAR_DECL, get_identifier (name),`
`gfc_charlen_type_node);`	`gfc_charlen_type_node);`
`DECL_ARTIFICIAL (length) = 1;`	`DECL_ARTIFICIAL (length) = 1;`
`TREE_USED (length) = 1;`	`TREE_USED (length) = 1;`
`if (sym->ns->proc_name->tlink != NULL)`	`if (sym->ns->proc_name->tlink != NULL)`
`gfc_defer_symbol_init (sym);`	`gfc_defer_symbol_init (sym);`

`sym->ts.u.cl->backend_decl = length;`	`sym->ts.u.cl->backend_decl = length;`
`}`	`}`

`gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);`	`gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);`
`return sym->ts.u.cl->backend_decl;`	`return sym->ts.u.cl->backend_decl;`
`}`	`}`

`/* If a variable is assigned a label, we add another two auxiliary`	`/* If a variable is assigned a label, we add another two auxiliary`
`variables. */`	`variables. */`

`static void`	`static void`
`gfc_add_assign_aux_vars (gfc_symbol * sym)`	`gfc_add_assign_aux_vars (gfc_symbol * sym)`
`{`	`{`
`tree addr;`	`tree addr;`
`tree length;`	`tree length;`
`tree decl;`	`tree decl;`

`gcc_assert (sym->backend_decl);`	`gcc_assert (sym->backend_decl);`

`decl = sym->backend_decl;`	`decl = sym->backend_decl;`
`gfc_allocate_lang_decl (decl);`	`gfc_allocate_lang_decl (decl);`
`GFC_DECL_ASSIGN (decl) = 1;`	`GFC_DECL_ASSIGN (decl) = 1;`
`length = build_decl (input_location,`	`length = build_decl (input_location,`
`VAR_DECL, create_tmp_var_name (sym->name),`	`VAR_DECL, create_tmp_var_name (sym->name),`
`gfc_charlen_type_node);`	`gfc_charlen_type_node);`
`addr = build_decl (input_location,`	`addr = build_decl (input_location,`
`VAR_DECL, create_tmp_var_name (sym->name),`	`VAR_DECL, create_tmp_var_name (sym->name),`
`pvoid_type_node);`	`pvoid_type_node);`
`gfc_finish_var_decl (length, sym);`	`gfc_finish_var_decl (length, sym);`
`gfc_finish_var_decl (addr, sym);`	`gfc_finish_var_decl (addr, sym);`
`/* STRING_LENGTH is also used as flag. Less than -1 means that`	`/* STRING_LENGTH is also used as flag. Less than -1 means that`
`ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the`	`ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the`
`target label's address. Otherwise, value is the length of a format string`	`target label's address. Otherwise, value is the length of a format string`
`and ASSIGN_ADDR is its address. */`	`and ASSIGN_ADDR is its address. */`
`if (TREE_STATIC (length))`	`if (TREE_STATIC (length))`
`DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);`	`DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);`
`else`	`else`
`gfc_defer_symbol_init (sym);`	`gfc_defer_symbol_init (sym);`

`GFC_DECL_STRING_LEN (decl) = length;`	`GFC_DECL_STRING_LEN (decl) = length;`
`GFC_DECL_ASSIGN_ADDR (decl) = addr;`	`GFC_DECL_ASSIGN_ADDR (decl) = addr;`
`}`	`}`


`static tree`	`static tree`
`add_attributes_to_decl (symbol_attribute sym_attr, tree list)`	`add_attributes_to_decl (symbol_attribute sym_attr, tree list)`
`{`	`{`
`unsigned id;`	`unsigned id;`
`tree attr;`	`tree attr;`

`for (id = 0; id < EXT_ATTR_NUM; id++)`	`for (id = 0; id < EXT_ATTR_NUM; id++)`
`if (sym_attr.ext_attr & (1 << id))`	`if (sym_attr.ext_attr & (1 << id))`
`{`	`{`
`attr = build_tree_list (`	`attr = build_tree_list (`
`get_identifier (ext_attr_list[id].middle_end_name),`	`get_identifier (ext_attr_list[id].middle_end_name),`
`NULL_TREE);`	`NULL_TREE);`
`list = chainon (list, attr);`	`list = chainon (list, attr);`
`}`	`}`

`return list;`	`return list;`
`}`	`}`


`/* Return the decl for a gfc_symbol, create it if it doesn't already`	`/* Return the decl for a gfc_symbol, create it if it doesn't already`
`exist. */`	`exist. */`

`tree`	`tree`
`gfc_get_symbol_decl (gfc_symbol * sym)`	`gfc_get_symbol_decl (gfc_symbol * sym)`
`{`	`{`
`tree decl;`	`tree decl;`
`tree length = NULL_TREE;`	`tree length = NULL_TREE;`
`tree attributes;`	`tree attributes;`
`int byref;`	`int byref;`

`gcc_assert (sym->attr.referenced`	`gcc_assert (sym->attr.referenced`
`\|\| sym->attr.use_assoc`	`\|\| sym->attr.use_assoc`
`\|\| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);`	`\|\| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);`

`if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)`	`if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)`
`byref = gfc_return_by_reference (sym->ns->proc_name);`	`byref = gfc_return_by_reference (sym->ns->proc_name);`
`else`	`else`
`byref = 0;`	`byref = 0;`

`if ((sym->attr.dummy && ! sym->attr.function) \|\| (sym->attr.result && byref))`	`if ((sym->attr.dummy && ! sym->attr.function) \|\| (sym->attr.result && byref))`
`{`	`{`
`/* Return via extra parameter. */`	`/* Return via extra parameter. */`
`if (sym->attr.result && byref`	`if (sym->attr.result && byref`
`&& !sym->backend_decl)`	`&& !sym->backend_decl)`
`{`	`{`
`sym->backend_decl =`	`sym->backend_decl =`
`DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);`	`DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);`
`/* For entry master function skip over the __entry`	`/* For entry master function skip over the __entry`
`argument. */`	`argument. */`
`if (sym->ns->proc_name->attr.entry_master)`	`if (sym->ns->proc_name->attr.entry_master)`
`sym->backend_decl = TREE_CHAIN (sym->backend_decl);`	`sym->backend_decl = TREE_CHAIN (sym->backend_decl);`
`}`	`}`

`/* Dummy variables should already have been created. */`	`/* Dummy variables should already have been created. */`
`gcc_assert (sym->backend_decl);`	`gcc_assert (sym->backend_decl);`

`/* Create a character length variable. */`	`/* Create a character length variable. */`
`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`{`	`{`
`if (sym->ts.u.cl->backend_decl == NULL_TREE)`	`if (sym->ts.u.cl->backend_decl == NULL_TREE)`
`length = gfc_create_string_length (sym);`	`length = gfc_create_string_length (sym);`
`else`	`else`
`length = sym->ts.u.cl->backend_decl;`	`length = sym->ts.u.cl->backend_decl;`
`if (TREE_CODE (length) == VAR_DECL`	`if (TREE_CODE (length) == VAR_DECL`
`&& DECL_CONTEXT (length) == NULL_TREE)`	`&& DECL_CONTEXT (length) == NULL_TREE)`
`{`	`{`
`/* Add the string length to the same context as the symbol. */`	`/* Add the string length to the same context as the symbol. */`
`if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)`	`if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)`
`gfc_add_decl_to_function (length);`	`gfc_add_decl_to_function (length);`
`else`	`else`
`gfc_add_decl_to_parent_function (length);`	`gfc_add_decl_to_parent_function (length);`

`gcc_assert (DECL_CONTEXT (sym->backend_decl) ==`	`gcc_assert (DECL_CONTEXT (sym->backend_decl) ==`
`DECL_CONTEXT (length));`	`DECL_CONTEXT (length));`

`gfc_defer_symbol_init (sym);`	`gfc_defer_symbol_init (sym);`
`}`	`}`
`}`	`}`

`/* Use a copy of the descriptor for dummy arrays. */`	`/* Use a copy of the descriptor for dummy arrays. */`
`if (sym->attr.dimension && !TREE_USED (sym->backend_decl))`	`if (sym->attr.dimension && !TREE_USED (sym->backend_decl))`
`{`	`{`
`decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);`	`decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);`
`/* Prevent the dummy from being detected as unused if it is copied. */`	`/* Prevent the dummy from being detected as unused if it is copied. */`
`if (sym->backend_decl != NULL && decl != sym->backend_decl)`	`if (sym->backend_decl != NULL && decl != sym->backend_decl)`
`DECL_ARTIFICIAL (sym->backend_decl) = 1;`	`DECL_ARTIFICIAL (sym->backend_decl) = 1;`
`sym->backend_decl = decl;`	`sym->backend_decl = decl;`
`}`	`}`

`TREE_USED (sym->backend_decl) = 1;`	`TREE_USED (sym->backend_decl) = 1;`
`if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)`	`if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)`
`{`	`{`
`gfc_add_assign_aux_vars (sym);`	`gfc_add_assign_aux_vars (sym);`
`}`	`}`

`if (sym->attr.dimension`	`if (sym->attr.dimension`
`&& DECL_LANG_SPECIFIC (sym->backend_decl)`	`&& DECL_LANG_SPECIFIC (sym->backend_decl)`
`&& GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)`	`&& GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)`
`&& DECL_CONTEXT (sym->backend_decl) != current_function_decl)`	`&& DECL_CONTEXT (sym->backend_decl) != current_function_decl)`
`gfc_nonlocal_dummy_array_decl (sym);`	`gfc_nonlocal_dummy_array_decl (sym);`

`return sym->backend_decl;`	`return sym->backend_decl;`
`}`	`}`

`if (sym->backend_decl)`	`if (sym->backend_decl)`
`return sym->backend_decl;`	`return sym->backend_decl;`

`/* If use associated and whole file compilation, use the module`	`/* If use associated and whole file compilation, use the module`
`declaration. This is only needed for intrinsic types because`	`declaration. This is only needed for intrinsic types because`
`they are substituted for one another during optimization. */`	`they are substituted for one another during optimization. */`
`if (gfc_option.flag_whole_file`	`if (gfc_option.flag_whole_file`
`&& sym->attr.flavor == FL_VARIABLE`	`&& sym->attr.flavor == FL_VARIABLE`
`&& sym->ts.type != BT_DERIVED`	`&& sym->ts.type != BT_DERIVED`
`&& sym->attr.use_assoc`	`&& sym->attr.use_assoc`
`&& sym->module)`	`&& sym->module)`
`{`	`{`
`gfc_gsymbol *gsym;`	`gfc_gsymbol *gsym;`

`gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);`	`gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);`
`if (gsym && gsym->ns && gsym->type == GSYM_MODULE)`	`if (gsym && gsym->ns && gsym->type == GSYM_MODULE)`
`{`	`{`
`gfc_symbol *s;`	`gfc_symbol *s;`
`s = NULL;`	`s = NULL;`
`gfc_find_symbol (sym->name, gsym->ns, 0, &s);`	`gfc_find_symbol (sym->name, gsym->ns, 0, &s);`
`if (s && s->backend_decl)`	`if (s && s->backend_decl)`
`{`	`{`
`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;`	`sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;`
`return s->backend_decl;`	`return s->backend_decl;`
`}`	`}`
`}`	`}`
`}`	`}`

`/* Catch function declarations. Only used for actual parameters and`	`/* Catch function declarations. Only used for actual parameters and`
`procedure pointers. */`	`procedure pointers. */`
`if (sym->attr.flavor == FL_PROCEDURE)`	`if (sym->attr.flavor == FL_PROCEDURE)`
`{`	`{`
`decl = gfc_get_extern_function_decl (sym);`	`decl = gfc_get_extern_function_decl (sym);`
`gfc_set_decl_location (decl, &sym->declared_at);`	`gfc_set_decl_location (decl, &sym->declared_at);`
`return decl;`	`return decl;`
`}`	`}`

`if (sym->attr.intrinsic)`	`if (sym->attr.intrinsic)`
`internal_error ("intrinsic variable which isn't a procedure");`	`internal_error ("intrinsic variable which isn't a procedure");`

`/* Create string length decl first so that they can be used in the`	`/* Create string length decl first so that they can be used in the`
`type declaration. */`	`type declaration. */`
`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`length = gfc_create_string_length (sym);`	`length = gfc_create_string_length (sym);`

`/* Create the decl for the variable. */`	`/* Create the decl for the variable. */`
`decl = build_decl (sym->declared_at.lb->location,`	`decl = build_decl (sym->declared_at.lb->location,`
`VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));`	`VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));`

`/* Add attributes to variables. Functions are handled elsewhere. */`	`/* Add attributes to variables. Functions are handled elsewhere. */`
`attributes = add_attributes_to_decl (sym->attr, NULL_TREE);`	`attributes = add_attributes_to_decl (sym->attr, NULL_TREE);`
`decl_attributes (&decl, attributes, 0);`	`decl_attributes (&decl, attributes, 0);`

`/* Symbols from modules should have their assembler names mangled.`	`/* Symbols from modules should have their assembler names mangled.`
`This is done here rather than in gfc_finish_var_decl because it`	`This is done here rather than in gfc_finish_var_decl because it`
`is different for string length variables. */`	`is different for string length variables. */`
`if (sym->module)`	`if (sym->module)`
`{`	`{`
`gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));`	`gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));`
`if (sym->attr.use_assoc)`	`if (sym->attr.use_assoc)`
`DECL_IGNORED_P (decl) = 1;`	`DECL_IGNORED_P (decl) = 1;`
`}`	`}`

`if (sym->attr.dimension)`	`if (sym->attr.dimension)`
`{`	`{`
`/* Create variables to hold the non-constant bits of array info. */`	`/* Create variables to hold the non-constant bits of array info. */`
`gfc_build_qualified_array (decl, sym);`	`gfc_build_qualified_array (decl, sym);`

`if ((sym->attr.allocatable \|\| !sym->attr.dummy) && !sym->attr.pointer)`	`if ((sym->attr.allocatable \|\| !sym->attr.dummy) && !sym->attr.pointer)`
`GFC_DECL_PACKED_ARRAY (decl) = 1;`	`GFC_DECL_PACKED_ARRAY (decl) = 1;`
`}`	`}`

`/* Remember this variable for allocation/cleanup. */`	`/* Remember this variable for allocation/cleanup. */`
`if (sym->attr.dimension \|\| sym->attr.allocatable`	`if (sym->attr.dimension \|\| sym->attr.allocatable`
`\|\| (sym->ts.type == BT_CLASS &&`	`\|\| (sym->ts.type == BT_CLASS &&`
`(sym->ts.u.derived->components->attr.dimension`	`(sym->ts.u.derived->components->attr.dimension`
`\|\| sym->ts.u.derived->components->attr.allocatable))`	`\|\| sym->ts.u.derived->components->attr.allocatable))`
`\|\| (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)`	`\|\| (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)`
`/* This applies a derived type default initializer. */`	`/* This applies a derived type default initializer. */`
`\|\| (sym->ts.type == BT_DERIVED`	`\|\| (sym->ts.type == BT_DERIVED`
`&& sym->attr.save == SAVE_NONE`	`&& sym->attr.save == SAVE_NONE`
`&& !sym->attr.data`	`&& !sym->attr.data`
`&& !sym->attr.allocatable`	`&& !sym->attr.allocatable`
`&& (sym->value && !sym->ns->proc_name->attr.is_main_program)`	`&& (sym->value && !sym->ns->proc_name->attr.is_main_program)`
`&& !sym->attr.use_assoc))`	`&& !sym->attr.use_assoc))`
`gfc_defer_symbol_init (sym);`	`gfc_defer_symbol_init (sym);`

`gfc_finish_var_decl (decl, sym);`	`gfc_finish_var_decl (decl, sym);`

`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`{`	`{`
`/* Character variables need special handling. */`	`/* Character variables need special handling. */`
`gfc_allocate_lang_decl (decl);`	`gfc_allocate_lang_decl (decl);`

`if (TREE_CODE (length) != INTEGER_CST)`	`if (TREE_CODE (length) != INTEGER_CST)`
`{`	`{`
`char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];`	`char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];`

`if (sym->module)`	`if (sym->module)`
`{`	`{`
`/* Also prefix the mangled name for symbols from modules. */`	`/* Also prefix the mangled name for symbols from modules. */`
`strcpy (&name[1], sym->name);`	`strcpy (&name[1], sym->name);`
`name[0] = '.';`	`name[0] = '.';`
`strcpy (&name[1],`	`strcpy (&name[1],`
`IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));`	`IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));`
`gfc_set_decl_assembler_name (decl, get_identifier (name));`	`gfc_set_decl_assembler_name (decl, get_identifier (name));`
`}`	`}`
`gfc_finish_var_decl (length, sym);`	`gfc_finish_var_decl (length, sym);`
`gcc_assert (!sym->value);`	`gcc_assert (!sym->value);`
`}`	`}`
`}`	`}`
`else if (sym->attr.subref_array_pointer)`	`else if (sym->attr.subref_array_pointer)`
`{`	`{`
`/* We need the span for these beasts. */`	`/* We need the span for these beasts. */`
`gfc_allocate_lang_decl (decl);`	`gfc_allocate_lang_decl (decl);`
`}`	`}`

`if (sym->attr.subref_array_pointer)`	`if (sym->attr.subref_array_pointer)`
`{`	`{`
`tree span;`	`tree span;`
`GFC_DECL_SUBREF_ARRAY_P (decl) = 1;`	`GFC_DECL_SUBREF_ARRAY_P (decl) = 1;`
`span = build_decl (input_location,`	`span = build_decl (input_location,`
`VAR_DECL, create_tmp_var_name ("span"),`	`VAR_DECL, create_tmp_var_name ("span"),`
`gfc_array_index_type);`	`gfc_array_index_type);`
`gfc_finish_var_decl (span, sym);`	`gfc_finish_var_decl (span, sym);`
`TREE_STATIC (span) = TREE_STATIC (decl);`	`TREE_STATIC (span) = TREE_STATIC (decl);`
`DECL_ARTIFICIAL (span) = 1;`	`DECL_ARTIFICIAL (span) = 1;`
`DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);`	`DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);`

`GFC_DECL_SPAN (decl) = span;`	`GFC_DECL_SPAN (decl) = span;`
`GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;`	`GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;`
`}`	`}`

`sym->backend_decl = decl;`	`sym->backend_decl = decl;`

`if (sym->attr.assign)`	`if (sym->attr.assign)`
`gfc_add_assign_aux_vars (sym);`	`gfc_add_assign_aux_vars (sym);`

`if (TREE_STATIC (decl) && !sym->attr.use_assoc)`	`if (TREE_STATIC (decl) && !sym->attr.use_assoc)`
`{`	`{`
`/* Add static initializer. */`	`/* Add static initializer. */`
`DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,`	`DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,`
`TREE_TYPE (decl), sym->attr.dimension,`	`TREE_TYPE (decl), sym->attr.dimension,`
`sym->attr.pointer \|\| sym->attr.allocatable);`	`sym->attr.pointer \|\| sym->attr.allocatable);`
`}`	`}`

`if (!TREE_STATIC (decl)`	`if (!TREE_STATIC (decl)`
`&& POINTER_TYPE_P (TREE_TYPE (decl))`	`&& POINTER_TYPE_P (TREE_TYPE (decl))`
`&& !sym->attr.pointer`	`&& !sym->attr.pointer`
`&& !sym->attr.allocatable`	`&& !sym->attr.allocatable`
`&& !sym->attr.proc_pointer)`	`&& !sym->attr.proc_pointer)`
`DECL_BY_REFERENCE (decl) = 1;`	`DECL_BY_REFERENCE (decl) = 1;`

`return decl;`	`return decl;`
`}`	`}`


`/* Substitute a temporary variable in place of the real one. */`	`/* Substitute a temporary variable in place of the real one. */`

`void`	`void`
`gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)`	`gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)`
`{`	`{`
`save->attr = sym->attr;`	`save->attr = sym->attr;`
`save->decl = sym->backend_decl;`	`save->decl = sym->backend_decl;`

`gfc_clear_attr (&sym->attr);`	`gfc_clear_attr (&sym->attr);`
`sym->attr.referenced = 1;`	`sym->attr.referenced = 1;`
`sym->attr.flavor = FL_VARIABLE;`	`sym->attr.flavor = FL_VARIABLE;`

`sym->backend_decl = decl;`	`sym->backend_decl = decl;`
`}`	`}`


`/* Restore the original variable. */`	`/* Restore the original variable. */`

`void`	`void`
`gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)`	`gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)`
`{`	`{`
`sym->attr = save->attr;`	`sym->attr = save->attr;`
`sym->backend_decl = save->decl;`	`sym->backend_decl = save->decl;`
`}`	`}`


`/* Declare a procedure pointer. */`	`/* Declare a procedure pointer. */`

`static tree`	`static tree`
`get_proc_pointer_decl (gfc_symbol *sym)`	`get_proc_pointer_decl (gfc_symbol *sym)`
`{`	`{`
`tree decl;`	`tree decl;`
`tree attributes;`	`tree attributes;`

`decl = sym->backend_decl;`	`decl = sym->backend_decl;`
`if (decl)`	`if (decl)`
`return decl;`	`return decl;`

`decl = build_decl (input_location,`	`decl = build_decl (input_location,`
`VAR_DECL, get_identifier (sym->name),`	`VAR_DECL, get_identifier (sym->name),`
`build_pointer_type (gfc_get_function_type (sym)));`	`build_pointer_type (gfc_get_function_type (sym)));`

`if ((sym->ns->proc_name`	`if ((sym->ns->proc_name`
`&& sym->ns->proc_name->backend_decl == current_function_decl)`	`&& sym->ns->proc_name->backend_decl == current_function_decl)`
`\|\| sym->attr.contained)`	`\|\| sym->attr.contained)`
`gfc_add_decl_to_function (decl);`	`gfc_add_decl_to_function (decl);`
`else if (sym->ns->proc_name->attr.flavor != FL_MODULE)`	`else if (sym->ns->proc_name->attr.flavor != FL_MODULE)`
`gfc_add_decl_to_parent_function (decl);`	`gfc_add_decl_to_parent_function (decl);`

`sym->backend_decl = decl;`	`sym->backend_decl = decl;`

`/* If a variable is USE associated, it's always external. */`	`/* If a variable is USE associated, it's always external. */`
`if (sym->attr.use_assoc)`	`if (sym->attr.use_assoc)`
`{`	`{`
`DECL_EXTERNAL (decl) = 1;`	`DECL_EXTERNAL (decl) = 1;`
`TREE_PUBLIC (decl) = 1;`	`TREE_PUBLIC (decl) = 1;`
`}`	`}`
`else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)`	`else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)`
`{`	`{`
`/* This is the declaration of a module variable. */`	`/* This is the declaration of a module variable. */`
`TREE_PUBLIC (decl) = 1;`	`TREE_PUBLIC (decl) = 1;`
`TREE_STATIC (decl) = 1;`	`TREE_STATIC (decl) = 1;`
`}`	`}`

`if (!sym->attr.use_assoc`	`if (!sym->attr.use_assoc`
`&& (sym->attr.save != SAVE_NONE \|\| sym->attr.data`	`&& (sym->attr.save != SAVE_NONE \|\| sym->attr.data`
`\|\| (sym->value && sym->ns->proc_name->attr.is_main_program)))`	`\|\| (sym->value && sym->ns->proc_name->attr.is_main_program)))`
`TREE_STATIC (decl) = 1;`	`TREE_STATIC (decl) = 1;`

`if (TREE_STATIC (decl) && sym->value)`	`if (TREE_STATIC (decl) && sym->value)`
`{`	`{`
`/* Add static initializer. */`	`/* Add static initializer. */`
`DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,`	`DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,`
`TREE_TYPE (decl),`	`TREE_TYPE (decl),`
`sym->attr.proc_pointer ? false : sym->attr.dimension,`	`sym->attr.proc_pointer ? false : sym->attr.dimension,`
`sym->attr.proc_pointer);`	`sym->attr.proc_pointer);`
`}`	`}`

`attributes = add_attributes_to_decl (sym->attr, NULL_TREE);`	`attributes = add_attributes_to_decl (sym->attr, NULL_TREE);`
`decl_attributes (&decl, attributes, 0);`	`decl_attributes (&decl, attributes, 0);`

`return decl;`	`return decl;`
`}`	`}`


`/* Get a basic decl for an external function. */`	`/* Get a basic decl for an external function. */`

`tree`	`tree`
`gfc_get_extern_function_decl (gfc_symbol * sym)`	`gfc_get_extern_function_decl (gfc_symbol * sym)`
`{`	`{`
`tree type;`	`tree type;`
`tree fndecl;`	`tree fndecl;`
`tree attributes;`	`tree attributes;`
`gfc_expr e;`	`gfc_expr e;`
`gfc_intrinsic_sym *isym;`	`gfc_intrinsic_sym *isym;`
`gfc_expr argexpr;`	`gfc_expr argexpr;`
`char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */`	`char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */`
`tree name;`	`tree name;`
`tree mangled_name;`	`tree mangled_name;`
`gfc_gsymbol *gsym;`	`gfc_gsymbol *gsym;`

`if (sym->backend_decl)`	`if (sym->backend_decl)`
`return sym->backend_decl;`	`return sym->backend_decl;`

`/* We should never be creating external decls for alternate entry points.`	`/* We should never be creating external decls for alternate entry points.`
`The procedure may be an alternate entry point, but we don't want/need`	`The procedure may be an alternate entry point, but we don't want/need`
`to know that. */`	`to know that. */`
`gcc_assert (!(sym->attr.entry \|\| sym->attr.entry_master));`	`gcc_assert (!(sym->attr.entry \|\| sym->attr.entry_master));`

`if (sym->attr.proc_pointer)`	`if (sym->attr.proc_pointer)`
`return get_proc_pointer_decl (sym);`	`return get_proc_pointer_decl (sym);`

`/* See if this is an external procedure from the same file. If so,`	`/* See if this is an external procedure from the same file. If so,`
`return the backend_decl. */`	`return the backend_decl. */`
`gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);`	`gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);`

`if (gfc_option.flag_whole_file`	`if (gfc_option.flag_whole_file`
`&& !sym->attr.use_assoc`	`&& !sym->attr.use_assoc`
`&& !sym->backend_decl`	`&& !sym->backend_decl`
`&& gsym && gsym->ns`	`&& gsym && gsym->ns`
`&& ((gsym->type == GSYM_SUBROUTINE) \|\| (gsym->type == GSYM_FUNCTION))`	`&& ((gsym->type == GSYM_SUBROUTINE) \|\| (gsym->type == GSYM_FUNCTION))`
`&& gsym->ns->proc_name->backend_decl)`	`&& gsym->ns->proc_name->backend_decl)`
`{`	`{`
`/* If the namespace has entries, the proc_name is the`	`/* If the namespace has entries, the proc_name is the`
`entry master. Find the entry and use its backend_decl.`	`entry master. Find the entry and use its backend_decl.`
`otherwise, use the proc_name backend_decl. */`	`otherwise, use the proc_name backend_decl. */`
`if (gsym->ns->entries)`	`if (gsym->ns->entries)`
`{`	`{`
`gfc_entry_list *entry = gsym->ns->entries;`	`gfc_entry_list *entry = gsym->ns->entries;`

`for (; entry; entry = entry->next)`	`for (; entry; entry = entry->next)`
`{`	`{`
`if (strcmp (gsym->name, entry->sym->name) == 0)`	`if (strcmp (gsym->name, entry->sym->name) == 0)`
`{`	`{`
`sym->backend_decl = entry->sym->backend_decl;`	`sym->backend_decl = entry->sym->backend_decl;`
`break;`	`break;`
`}`	`}`
`}`	`}`
`}`	`}`
`else`	`else`
`{`	`{`
`sym->backend_decl = gsym->ns->proc_name->backend_decl;`	`sym->backend_decl = gsym->ns->proc_name->backend_decl;`
`}`	`}`

`if (sym->backend_decl)`	`if (sym->backend_decl)`
`return sym->backend_decl;`	`return sym->backend_decl;`
`}`	`}`

`/* See if this is a module procedure from the same file. If so,`	`/* See if this is a module procedure from the same file. If so,`
`return the backend_decl. */`	`return the backend_decl. */`
`if (sym->module)`	`if (sym->module)`
`gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);`	`gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);`

`if (gfc_option.flag_whole_file`	`if (gfc_option.flag_whole_file`
`&& gsym && gsym->ns`	`&& gsym && gsym->ns`
`&& gsym->type == GSYM_MODULE)`	`&& gsym->type == GSYM_MODULE)`
`{`	`{`
`gfc_symbol *s;`	`gfc_symbol *s;`

`s = NULL;`	`s = NULL;`
`gfc_find_symbol (sym->name, gsym->ns, 0, &s);`	`gfc_find_symbol (sym->name, gsym->ns, 0, &s);`
`if (s && s->backend_decl)`	`if (s && s->backend_decl)`
`{`	`{`
`sym->backend_decl = s->backend_decl;`	`sym->backend_decl = s->backend_decl;`
`return sym->backend_decl;`	`return sym->backend_decl;`
`}`	`}`
`}`	`}`

`if (sym->attr.intrinsic)`	`if (sym->attr.intrinsic)`
`{`	`{`
`/* Call the resolution function to get the actual name. This is`	`/* Call the resolution function to get the actual name. This is`
`a nasty hack which relies on the resolution functions only looking`	`a nasty hack which relies on the resolution functions only looking`
`at the first argument. We pass NULL for the second argument`	`at the first argument. We pass NULL for the second argument`
`otherwise things like AINT get confused. */`	`otherwise things like AINT get confused. */`
`isym = gfc_find_function (sym->name);`	`isym = gfc_find_function (sym->name);`
`gcc_assert (isym->resolve.f0 != NULL);`	`gcc_assert (isym->resolve.f0 != NULL);`

`memset (&e, 0, sizeof (e));`	`memset (&e, 0, sizeof (e));`
`e.expr_type = EXPR_FUNCTION;`	`e.expr_type = EXPR_FUNCTION;`

`memset (&argexpr, 0, sizeof (argexpr));`	`memset (&argexpr, 0, sizeof (argexpr));`
`gcc_assert (isym->formal);`	`gcc_assert (isym->formal);`
`argexpr.ts = isym->formal->ts;`	`argexpr.ts = isym->formal->ts;`

`if (isym->formal->next == NULL)`	`if (isym->formal->next == NULL)`
`isym->resolve.f1 (&e, &argexpr);`	`isym->resolve.f1 (&e, &argexpr);`
`else`	`else`
`{`	`{`
`if (isym->formal->next->next == NULL)`	`if (isym->formal->next->next == NULL)`
`isym->resolve.f2 (&e, &argexpr, NULL);`	`isym->resolve.f2 (&e, &argexpr, NULL);`
`else`	`else`
`{`	`{`
`if (isym->formal->next->next->next == NULL)`	`if (isym->formal->next->next->next == NULL)`
`isym->resolve.f3 (&e, &argexpr, NULL, NULL);`	`isym->resolve.f3 (&e, &argexpr, NULL, NULL);`
`else`	`else`
`{`	`{`
`/* All specific intrinsics take less than 5 arguments. */`	`/* All specific intrinsics take less than 5 arguments. */`
`gcc_assert (isym->formal->next->next->next->next == NULL);`	`gcc_assert (isym->formal->next->next->next->next == NULL);`
`isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);`	`isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);`
`}`	`}`
`}`	`}`
`}`	`}`

`if (gfc_option.flag_f2c`	`if (gfc_option.flag_f2c`
`&& ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)`	`&& ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)`
`\|\| e.ts.type == BT_COMPLEX))`	`\|\| e.ts.type == BT_COMPLEX))`
`{`	`{`
`/* Specific which needs a different implementation if f2c`	`/* Specific which needs a different implementation if f2c`
`calling conventions are used. */`	`calling conventions are used. */`
`sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);`	`sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);`
`}`	`}`
`else`	`else`
`sprintf (s, "_gfortran_specific%s", e.value.function.name);`	`sprintf (s, "_gfortran_specific%s", e.value.function.name);`

`name = get_identifier (s);`	`name = get_identifier (s);`
`mangled_name = name;`	`mangled_name = name;`
`}`	`}`
`else`	`else`
`{`	`{`
`name = gfc_sym_identifier (sym);`	`name = gfc_sym_identifier (sym);`
`mangled_name = gfc_sym_mangled_function_id (sym);`	`mangled_name = gfc_sym_mangled_function_id (sym);`
`}`	`}`

`type = gfc_get_function_type (sym);`	`type = gfc_get_function_type (sym);`
`fndecl = build_decl (input_location,`	`fndecl = build_decl (input_location,`
`FUNCTION_DECL, name, type);`	`FUNCTION_DECL, name, type);`

`attributes = add_attributes_to_decl (sym->attr, NULL_TREE);`	`attributes = add_attributes_to_decl (sym->attr, NULL_TREE);`
`decl_attributes (&fndecl, attributes, 0);`	`decl_attributes (&fndecl, attributes, 0);`

`gfc_set_decl_assembler_name (fndecl, mangled_name);`	`gfc_set_decl_assembler_name (fndecl, mangled_name);`

`/* Set the context of this decl. */`	`/* Set the context of this decl. */`
`if (0 && sym->ns && sym->ns->proc_name)`	`if (0 && sym->ns && sym->ns->proc_name)`
`{`	`{`
`/* TODO: Add external decls to the appropriate scope. */`	`/* TODO: Add external decls to the appropriate scope. */`
`DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;`	`DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;`
`}`	`}`
`else`	`else`
`{`	`{`
`/* Global declaration, e.g. intrinsic subroutine. */`	`/* Global declaration, e.g. intrinsic subroutine. */`
`DECL_CONTEXT (fndecl) = NULL_TREE;`	`DECL_CONTEXT (fndecl) = NULL_TREE;`
`}`	`}`

`DECL_EXTERNAL (fndecl) = 1;`	`DECL_EXTERNAL (fndecl) = 1;`

`/* This specifies if a function is globally addressable, i.e. it is`	`/* This specifies if a function is globally addressable, i.e. it is`
`the opposite of declaring static in C. */`	`the opposite of declaring static in C. */`
`TREE_PUBLIC (fndecl) = 1;`	`TREE_PUBLIC (fndecl) = 1;`

`/* Set attributes for PURE functions. A call to PURE function in the`	`/* Set attributes for PURE functions. A call to PURE function in the`
`Fortran 95 sense is both pure and without side effects in the C`	`Fortran 95 sense is both pure and without side effects in the C`
`sense. */`	`sense. */`
`if (sym->attr.pure \|\| sym->attr.elemental)`	`if (sym->attr.pure \|\| sym->attr.elemental)`
`{`	`{`
`if (sym->attr.function && !gfc_return_by_reference (sym))`	`if (sym->attr.function && !gfc_return_by_reference (sym))`
`DECL_PURE_P (fndecl) = 1;`	`DECL_PURE_P (fndecl) = 1;`
`/* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)`	`/* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)`
`parameters and don't use alternate returns (is this`	`parameters and don't use alternate returns (is this`
`allowed?). In that case, calls to them are meaningless, and`	`allowed?). In that case, calls to them are meaningless, and`
`can be optimized away. See also in build_function_decl(). */`	`can be optimized away. See also in build_function_decl(). */`
`TREE_SIDE_EFFECTS (fndecl) = 0;`	`TREE_SIDE_EFFECTS (fndecl) = 0;`
`}`	`}`

`/* Mark non-returning functions. */`	`/* Mark non-returning functions. */`
`if (sym->attr.noreturn)`	`if (sym->attr.noreturn)`
`TREE_THIS_VOLATILE(fndecl) = 1;`	`TREE_THIS_VOLATILE(fndecl) = 1;`

`sym->backend_decl = fndecl;`	`sym->backend_decl = fndecl;`

`if (DECL_CONTEXT (fndecl) == NULL_TREE)`	`if (DECL_CONTEXT (fndecl) == NULL_TREE)`
`pushdecl_top_level (fndecl);`	`pushdecl_top_level (fndecl);`

`return fndecl;`	`return fndecl;`
`}`	`}`


`/* Create a declaration for a procedure. For external functions (in the C`	`/* Create a declaration for a procedure. For external functions (in the C`
`sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is`	`sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is`
`a master function with alternate entry points. */`	`a master function with alternate entry points. */`

`static void`	`static void`
`build_function_decl (gfc_symbol * sym)`	`build_function_decl (gfc_symbol * sym)`
`{`	`{`
`tree fndecl, type, attributes;`	`tree fndecl, type, attributes;`
`symbol_attribute attr;`	`symbol_attribute attr;`
`tree result_decl;`	`tree result_decl;`
`gfc_formal_arglist *f;`	`gfc_formal_arglist *f;`

`gcc_assert (!sym->backend_decl);`	`gcc_assert (!sym->backend_decl);`
`gcc_assert (!sym->attr.external);`	`gcc_assert (!sym->attr.external);`

`/* Set the line and filename. sym->declared_at seems to point to the`	`/* Set the line and filename. sym->declared_at seems to point to the`
`last statement for subroutines, but it'll do for now. */`	`last statement for subroutines, but it'll do for now. */`
`gfc_set_backend_locus (&sym->declared_at);`	`gfc_set_backend_locus (&sym->declared_at);`

`/* Allow only one nesting level. Allow public declarations. */`	`/* Allow only one nesting level. Allow public declarations. */`
`gcc_assert (current_function_decl == NULL_TREE`	`gcc_assert (current_function_decl == NULL_TREE`
`\|\| DECL_CONTEXT (current_function_decl) == NULL_TREE`	`\|\| DECL_CONTEXT (current_function_decl) == NULL_TREE`
`\|\| TREE_CODE (DECL_CONTEXT (current_function_decl))`	`\|\| TREE_CODE (DECL_CONTEXT (current_function_decl))`
`== NAMESPACE_DECL);`	`== NAMESPACE_DECL);`

`type = gfc_get_function_type (sym);`	`type = gfc_get_function_type (sym);`
`fndecl = build_decl (input_location,`	`fndecl = build_decl (input_location,`
`FUNCTION_DECL, gfc_sym_identifier (sym), type);`	`FUNCTION_DECL, gfc_sym_identifier (sym), type);`

`attr = sym->attr;`	`attr = sym->attr;`

`attributes = add_attributes_to_decl (attr, NULL_TREE);`	`attributes = add_attributes_to_decl (attr, NULL_TREE);`
`decl_attributes (&fndecl, attributes, 0);`	`decl_attributes (&fndecl, attributes, 0);`

`/* Perform name mangling if this is a top level or module procedure. */`	`/* Perform name mangling if this is a top level or module procedure. */`
`if (current_function_decl == NULL_TREE)`	`if (current_function_decl == NULL_TREE)`
`gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));`	`gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));`

`/* Figure out the return type of the declared function, and build a`	`/* Figure out the return type of the declared function, and build a`
`RESULT_DECL for it. If this is a subroutine with alternate`	`RESULT_DECL for it. If this is a subroutine with alternate`
`returns, build a RESULT_DECL for it. */`	`returns, build a RESULT_DECL for it. */`
`result_decl = NULL_TREE;`	`result_decl = NULL_TREE;`
`/* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */`	`/* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */`
`if (attr.function)`	`if (attr.function)`
`{`	`{`
`if (gfc_return_by_reference (sym))`	`if (gfc_return_by_reference (sym))`
`type = void_type_node;`	`type = void_type_node;`
`else`	`else`
`{`	`{`
`if (sym->result != sym)`	`if (sym->result != sym)`
`result_decl = gfc_sym_identifier (sym->result);`	`result_decl = gfc_sym_identifier (sym->result);`

`type = TREE_TYPE (TREE_TYPE (fndecl));`	`type = TREE_TYPE (TREE_TYPE (fndecl));`
`}`	`}`
`}`	`}`
`else`	`else`
`{`	`{`
`/* Look for alternate return placeholders. */`	`/* Look for alternate return placeholders. */`
`int has_alternate_returns = 0;`	`int has_alternate_returns = 0;`
`for (f = sym->formal; f; f = f->next)`	`for (f = sym->formal; f; f = f->next)`
`{`	`{`
`if (f->sym == NULL)`	`if (f->sym == NULL)`
`{`	`{`
`has_alternate_returns = 1;`	`has_alternate_returns = 1;`
`break;`	`break;`
`}`	`}`
`}`	`}`

`if (has_alternate_returns)`	`if (has_alternate_returns)`
`type = integer_type_node;`	`type = integer_type_node;`
`else`	`else`
`type = void_type_node;`	`type = void_type_node;`
`}`	`}`

`result_decl = build_decl (input_location,`	`result_decl = build_decl (input_location,`
`RESULT_DECL, result_decl, type);`	`RESULT_DECL, result_decl, type);`
`DECL_ARTIFICIAL (result_decl) = 1;`	`DECL_ARTIFICIAL (result_decl) = 1;`
`DECL_IGNORED_P (result_decl) = 1;`	`DECL_IGNORED_P (result_decl) = 1;`
`DECL_CONTEXT (result_decl) = fndecl;`	`DECL_CONTEXT (result_decl) = fndecl;`
`DECL_RESULT (fndecl) = result_decl;`	`DECL_RESULT (fndecl) = result_decl;`

`/* Don't call layout_decl for a RESULT_DECL.`	`/* Don't call layout_decl for a RESULT_DECL.`
`layout_decl (result_decl, 0); */`	`layout_decl (result_decl, 0); */`

`/* Set up all attributes for the function. */`	`/* Set up all attributes for the function. */`
`DECL_CONTEXT (fndecl) = current_function_decl;`	`DECL_CONTEXT (fndecl) = current_function_decl;`
`DECL_EXTERNAL (fndecl) = 0;`	`DECL_EXTERNAL (fndecl) = 0;`

`/* This specifies if a function is globally visible, i.e. it is`	`/* This specifies if a function is globally visible, i.e. it is`
`the opposite of declaring static in C. */`	`the opposite of declaring static in C. */`
`if (DECL_CONTEXT (fndecl) == NULL_TREE`	`if (DECL_CONTEXT (fndecl) == NULL_TREE`
`&& !sym->attr.entry_master && !sym->attr.is_main_program)`	`&& !sym->attr.entry_master && !sym->attr.is_main_program)`
`TREE_PUBLIC (fndecl) = 1;`	`TREE_PUBLIC (fndecl) = 1;`

`/* TREE_STATIC means the function body is defined here. */`	`/* TREE_STATIC means the function body is defined here. */`
`TREE_STATIC (fndecl) = 1;`	`TREE_STATIC (fndecl) = 1;`

`/* Set attributes for PURE functions. A call to a PURE function in the`	`/* Set attributes for PURE functions. A call to a PURE function in the`
`Fortran 95 sense is both pure and without side effects in the C`	`Fortran 95 sense is both pure and without side effects in the C`
`sense. */`	`sense. */`
`if (attr.pure \|\| attr.elemental)`	`if (attr.pure \|\| attr.elemental)`
`{`	`{`
`/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments`	`/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments`
`including an alternate return. In that case it can also be`	`including an alternate return. In that case it can also be`
`marked as PURE. See also in gfc_get_extern_function_decl(). */`	`marked as PURE. See also in gfc_get_extern_function_decl(). */`
`if (attr.function && !gfc_return_by_reference (sym))`	`if (attr.function && !gfc_return_by_reference (sym))`
`DECL_PURE_P (fndecl) = 1;`	`DECL_PURE_P (fndecl) = 1;`
`TREE_SIDE_EFFECTS (fndecl) = 0;`	`TREE_SIDE_EFFECTS (fndecl) = 0;`
`}`	`}`


`/* Layout the function declaration and put it in the binding level`	`/* Layout the function declaration and put it in the binding level`
`of the current function. */`	`of the current function. */`
`pushdecl (fndecl);`	`pushdecl (fndecl);`

`sym->backend_decl = fndecl;`	`sym->backend_decl = fndecl;`
`}`	`}`


`/* Create the DECL_ARGUMENTS for a procedure. */`	`/* Create the DECL_ARGUMENTS for a procedure. */`

`static void`	`static void`
`create_function_arglist (gfc_symbol * sym)`	`create_function_arglist (gfc_symbol * sym)`
`{`	`{`
`tree fndecl;`	`tree fndecl;`
`gfc_formal_arglist *f;`	`gfc_formal_arglist *f;`
`tree typelist, hidden_typelist;`	`tree typelist, hidden_typelist;`
`tree arglist, hidden_arglist;`	`tree arglist, hidden_arglist;`
`tree type;`	`tree type;`
`tree parm;`	`tree parm;`

`fndecl = sym->backend_decl;`	`fndecl = sym->backend_decl;`

`/* Build formal argument list. Make sure that their TREE_CONTEXT is`	`/* Build formal argument list. Make sure that their TREE_CONTEXT is`
`the new FUNCTION_DECL node. */`	`the new FUNCTION_DECL node. */`
`arglist = NULL_TREE;`	`arglist = NULL_TREE;`
`hidden_arglist = NULL_TREE;`	`hidden_arglist = NULL_TREE;`
`typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));`	`typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));`

`if (sym->attr.entry_master)`	`if (sym->attr.entry_master)`
`{`	`{`
`type = TREE_VALUE (typelist);`	`type = TREE_VALUE (typelist);`
`parm = build_decl (input_location,`	`parm = build_decl (input_location,`
`PARM_DECL, get_identifier ("__entry"), type);`	`PARM_DECL, get_identifier ("__entry"), type);`

`DECL_CONTEXT (parm) = fndecl;`	`DECL_CONTEXT (parm) = fndecl;`
`DECL_ARG_TYPE (parm) = type;`	`DECL_ARG_TYPE (parm) = type;`
`TREE_READONLY (parm) = 1;`	`TREE_READONLY (parm) = 1;`
`gfc_finish_decl (parm);`	`gfc_finish_decl (parm);`
`DECL_ARTIFICIAL (parm) = 1;`	`DECL_ARTIFICIAL (parm) = 1;`

`arglist = chainon (arglist, parm);`	`arglist = chainon (arglist, parm);`
`typelist = TREE_CHAIN (typelist);`	`typelist = TREE_CHAIN (typelist);`
`}`	`}`

`if (gfc_return_by_reference (sym))`	`if (gfc_return_by_reference (sym))`
`{`	`{`
`tree type = TREE_VALUE (typelist), length = NULL;`	`tree type = TREE_VALUE (typelist), length = NULL;`

`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`{`	`{`
`/* Length of character result. */`	`/* Length of character result. */`
`tree len_type = TREE_VALUE (TREE_CHAIN (typelist));`	`tree len_type = TREE_VALUE (TREE_CHAIN (typelist));`
`gcc_assert (len_type == gfc_charlen_type_node);`	`gcc_assert (len_type == gfc_charlen_type_node);`

`length = build_decl (input_location,`	`length = build_decl (input_location,`
`PARM_DECL,`	`PARM_DECL,`
`get_identifier (".__result"),`	`get_identifier (".__result"),`
`len_type);`	`len_type);`
`if (!sym->ts.u.cl->length)`	`if (!sym->ts.u.cl->length)`
`{`	`{`
`sym->ts.u.cl->backend_decl = length;`	`sym->ts.u.cl->backend_decl = length;`
`TREE_USED (length) = 1;`	`TREE_USED (length) = 1;`
`}`	`}`
`gcc_assert (TREE_CODE (length) == PARM_DECL);`	`gcc_assert (TREE_CODE (length) == PARM_DECL);`
`DECL_CONTEXT (length) = fndecl;`	`DECL_CONTEXT (length) = fndecl;`
`DECL_ARG_TYPE (length) = len_type;`	`DECL_ARG_TYPE (length) = len_type;`
`TREE_READONLY (length) = 1;`	`TREE_READONLY (length) = 1;`
`DECL_ARTIFICIAL (length) = 1;`	`DECL_ARTIFICIAL (length) = 1;`
`gfc_finish_decl (length);`	`gfc_finish_decl (length);`
`if (sym->ts.u.cl->backend_decl == NULL`	`if (sym->ts.u.cl->backend_decl == NULL`
`\|\| sym->ts.u.cl->backend_decl == length)`	`\|\| sym->ts.u.cl->backend_decl == length)`
`{`	`{`
`gfc_symbol *arg;`	`gfc_symbol *arg;`
`tree backend_decl;`	`tree backend_decl;`

`if (sym->ts.u.cl->backend_decl == NULL)`	`if (sym->ts.u.cl->backend_decl == NULL)`
`{`	`{`
`tree len = build_decl (input_location,`	`tree len = build_decl (input_location,`
`VAR_DECL,`	`VAR_DECL,`
`get_identifier ("..__result"),`	`get_identifier ("..__result"),`
`gfc_charlen_type_node);`	`gfc_charlen_type_node);`
`DECL_ARTIFICIAL (len) = 1;`	`DECL_ARTIFICIAL (len) = 1;`
`TREE_USED (len) = 1;`	`TREE_USED (len) = 1;`
`sym->ts.u.cl->backend_decl = len;`	`sym->ts.u.cl->backend_decl = len;`
`}`	`}`

`/* Make sure PARM_DECL type doesn't point to incomplete type. */`	`/* Make sure PARM_DECL type doesn't point to incomplete type. */`
`arg = sym->result ? sym->result : sym;`	`arg = sym->result ? sym->result : sym;`
`backend_decl = arg->backend_decl;`	`backend_decl = arg->backend_decl;`
`/* Temporary clear it, so that gfc_sym_type creates complete`	`/* Temporary clear it, so that gfc_sym_type creates complete`
`type. */`	`type. */`
`arg->backend_decl = NULL;`	`arg->backend_decl = NULL;`
`type = gfc_sym_type (arg);`	`type = gfc_sym_type (arg);`
`arg->backend_decl = backend_decl;`	`arg->backend_decl = backend_decl;`
`type = build_reference_type (type);`	`type = build_reference_type (type);`
`}`	`}`
`}`	`}`

`parm = build_decl (input_location,`	`parm = build_decl (input_location,`
`PARM_DECL, get_identifier ("__result"), type);`	`PARM_DECL, get_identifier ("__result"), type);`

`DECL_CONTEXT (parm) = fndecl;`	`DECL_CONTEXT (parm) = fndecl;`
`DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);`	`DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);`
`TREE_READONLY (parm) = 1;`	`TREE_READONLY (parm) = 1;`
`DECL_ARTIFICIAL (parm) = 1;`	`DECL_ARTIFICIAL (parm) = 1;`
`gfc_finish_decl (parm);`	`gfc_finish_decl (parm);`

`arglist = chainon (arglist, parm);`	`arglist = chainon (arglist, parm);`
`typelist = TREE_CHAIN (typelist);`	`typelist = TREE_CHAIN (typelist);`

`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`{`	`{`
`gfc_allocate_lang_decl (parm);`	`gfc_allocate_lang_decl (parm);`
`arglist = chainon (arglist, length);`	`arglist = chainon (arglist, length);`
`typelist = TREE_CHAIN (typelist);`	`typelist = TREE_CHAIN (typelist);`
`}`	`}`
`}`	`}`

`hidden_typelist = typelist;`	`hidden_typelist = typelist;`
`for (f = sym->formal; f; f = f->next)`	`for (f = sym->formal; f; f = f->next)`
`if (f->sym != NULL) /* Ignore alternate returns. */`	`if (f->sym != NULL) /* Ignore alternate returns. */`
`hidden_typelist = TREE_CHAIN (hidden_typelist);`	`hidden_typelist = TREE_CHAIN (hidden_typelist);`

`for (f = sym->formal; f; f = f->next)`	`for (f = sym->formal; f; f = f->next)`
`{`	`{`
`char name[GFC_MAX_SYMBOL_LEN + 2];`	`char name[GFC_MAX_SYMBOL_LEN + 2];`

`/* Ignore alternate returns. */`	`/* Ignore alternate returns. */`
`if (f->sym == NULL)`	`if (f->sym == NULL)`
`continue;`	`continue;`

`type = TREE_VALUE (typelist);`	`type = TREE_VALUE (typelist);`

`if (f->sym->ts.type == BT_CHARACTER`	`if (f->sym->ts.type == BT_CHARACTER`
`&& (!sym->attr.is_bind_c \|\| sym->attr.entry_master))`	`&& (!sym->attr.is_bind_c \|\| sym->attr.entry_master))`
`{`	`{`
`tree len_type = TREE_VALUE (hidden_typelist);`	`tree len_type = TREE_VALUE (hidden_typelist);`
`tree length = NULL_TREE;`	`tree length = NULL_TREE;`
`gcc_assert (len_type == gfc_charlen_type_node);`	`gcc_assert (len_type == gfc_charlen_type_node);`

`strcpy (&name[1], f->sym->name);`	`strcpy (&name[1], f->sym->name);`
`name[0] = '_';`	`name[0] = '_';`
`length = build_decl (input_location,`	`length = build_decl (input_location,`
`PARM_DECL, get_identifier (name), len_type);`	`PARM_DECL, get_identifier (name), len_type);`

`hidden_arglist = chainon (hidden_arglist, length);`	`hidden_arglist = chainon (hidden_arglist, length);`
`DECL_CONTEXT (length) = fndecl;`	`DECL_CONTEXT (length) = fndecl;`
`DECL_ARTIFICIAL (length) = 1;`	`DECL_ARTIFICIAL (length) = 1;`
`DECL_ARG_TYPE (length) = len_type;`	`DECL_ARG_TYPE (length) = len_type;`
`TREE_READONLY (length) = 1;`	`TREE_READONLY (length) = 1;`
`gfc_finish_decl (length);`	`gfc_finish_decl (length);`

`/* Remember the passed value. */`	`/* Remember the passed value. */`
`if (f->sym->ts.u.cl->passed_length != NULL)`	`if (f->sym->ts.u.cl->passed_length != NULL)`
`{`	`{`
`/* This can happen if the same type is used for multiple`	`/* This can happen if the same type is used for multiple`
`arguments. We need to copy cl as otherwise`	`arguments. We need to copy cl as otherwise`
`cl->passed_length gets overwritten. */`	`cl->passed_length gets overwritten. */`
`f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);`	`f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);`
`}`	`}`
`f->sym->ts.u.cl->passed_length = length;`	`f->sym->ts.u.cl->passed_length = length;`

`/* Use the passed value for assumed length variables. */`	`/* Use the passed value for assumed length variables. */`
`if (!f->sym->ts.u.cl->length)`	`if (!f->sym->ts.u.cl->length)`
`{`	`{`
`TREE_USED (length) = 1;`	`TREE_USED (length) = 1;`
`gcc_assert (!f->sym->ts.u.cl->backend_decl);`	`gcc_assert (!f->sym->ts.u.cl->backend_decl);`
`f->sym->ts.u.cl->backend_decl = length;`	`f->sym->ts.u.cl->backend_decl = length;`
`}`	`}`

`hidden_typelist = TREE_CHAIN (hidden_typelist);`	`hidden_typelist = TREE_CHAIN (hidden_typelist);`

`if (f->sym->ts.u.cl->backend_decl == NULL`	`if (f->sym->ts.u.cl->backend_decl == NULL`
`\|\| f->sym->ts.u.cl->backend_decl == length)`	`\|\| f->sym->ts.u.cl->backend_decl == length)`
`{`	`{`
`if (f->sym->ts.u.cl->backend_decl == NULL)`	`if (f->sym->ts.u.cl->backend_decl == NULL)`
`gfc_create_string_length (f->sym);`	`gfc_create_string_length (f->sym);`

`/* Make sure PARM_DECL type doesn't point to incomplete type. */`	`/* Make sure PARM_DECL type doesn't point to incomplete type. */`
`if (f->sym->attr.flavor == FL_PROCEDURE)`	`if (f->sym->attr.flavor == FL_PROCEDURE)`
`type = build_pointer_type (gfc_get_function_type (f->sym));`	`type = build_pointer_type (gfc_get_function_type (f->sym));`
`else`	`else`
`type = gfc_sym_type (f->sym);`	`type = gfc_sym_type (f->sym);`
`}`	`}`
`}`	`}`

`/* For non-constant length array arguments, make sure they use`	`/* For non-constant length array arguments, make sure they use`
`a different type node from TYPE_ARG_TYPES type. */`	`a different type node from TYPE_ARG_TYPES type. */`
`if (f->sym->attr.dimension`	`if (f->sym->attr.dimension`
`&& type == TREE_VALUE (typelist)`	`&& type == TREE_VALUE (typelist)`
`&& TREE_CODE (type) == POINTER_TYPE`	`&& TREE_CODE (type) == POINTER_TYPE`
`&& GFC_ARRAY_TYPE_P (type)`	`&& GFC_ARRAY_TYPE_P (type)`
`&& f->sym->as->type != AS_ASSUMED_SIZE`	`&& f->sym->as->type != AS_ASSUMED_SIZE`
`&& ! COMPLETE_TYPE_P (TREE_TYPE (type)))`	`&& ! COMPLETE_TYPE_P (TREE_TYPE (type)))`
`{`	`{`
`if (f->sym->attr.flavor == FL_PROCEDURE)`	`if (f->sym->attr.flavor == FL_PROCEDURE)`
`type = build_pointer_type (gfc_get_function_type (f->sym));`	`type = build_pointer_type (gfc_get_function_type (f->sym));`
`else`	`else`
`type = gfc_sym_type (f->sym);`	`type = gfc_sym_type (f->sym);`
`}`	`}`

`if (f->sym->attr.proc_pointer)`	`if (f->sym->attr.proc_pointer)`
`type = build_pointer_type (type);`	`type = build_pointer_type (type);`

`/* Build the argument declaration. */`	`/* Build the argument declaration. */`
`parm = build_decl (input_location,`	`parm = build_decl (input_location,`
`PARM_DECL, gfc_sym_identifier (f->sym), type);`	`PARM_DECL, gfc_sym_identifier (f->sym), type);`

`/* Fill in arg stuff. */`	`/* Fill in arg stuff. */`
`DECL_CONTEXT (parm) = fndecl;`	`DECL_CONTEXT (parm) = fndecl;`
`DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);`	`DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);`
`/* All implementation args are read-only. */`	`/* All implementation args are read-only. */`
`TREE_READONLY (parm) = 1;`	`TREE_READONLY (parm) = 1;`
`if (POINTER_TYPE_P (type)`	`if (POINTER_TYPE_P (type)`
`&& (!f->sym->attr.proc_pointer`	`&& (!f->sym->attr.proc_pointer`
`&& f->sym->attr.flavor != FL_PROCEDURE))`	`&& f->sym->attr.flavor != FL_PROCEDURE))`
`DECL_BY_REFERENCE (parm) = 1;`	`DECL_BY_REFERENCE (parm) = 1;`

`gfc_finish_decl (parm);`	`gfc_finish_decl (parm);`

`f->sym->backend_decl = parm;`	`f->sym->backend_decl = parm;`

`arglist = chainon (arglist, parm);`	`arglist = chainon (arglist, parm);`
`typelist = TREE_CHAIN (typelist);`	`typelist = TREE_CHAIN (typelist);`
`}`	`}`

`/* Add the hidden string length parameters, unless the procedure`	`/* Add the hidden string length parameters, unless the procedure`
`is bind(C). */`	`is bind(C). */`
`if (!sym->attr.is_bind_c)`	`if (!sym->attr.is_bind_c)`
`arglist = chainon (arglist, hidden_arglist);`	`arglist = chainon (arglist, hidden_arglist);`

`gcc_assert (hidden_typelist == NULL_TREE`	`gcc_assert (hidden_typelist == NULL_TREE`
`\|\| TREE_VALUE (hidden_typelist) == void_type_node);`	`\|\| TREE_VALUE (hidden_typelist) == void_type_node);`
`DECL_ARGUMENTS (fndecl) = arglist;`	`DECL_ARGUMENTS (fndecl) = arglist;`
`}`	`}`

`/* Do the setup necessary before generating the body of a function. */`	`/* Do the setup necessary before generating the body of a function. */`

`static void`	`static void`
`trans_function_start (gfc_symbol * sym)`	`trans_function_start (gfc_symbol * sym)`
`{`	`{`
`tree fndecl;`	`tree fndecl;`

`fndecl = sym->backend_decl;`	`fndecl = sym->backend_decl;`

`/* Let GCC know the current scope is this function. */`	`/* Let GCC know the current scope is this function. */`
`current_function_decl = fndecl;`	`current_function_decl = fndecl;`

`/* Let the world know what we're about to do. */`	`/* Let the world know what we're about to do. */`
`announce_function (fndecl);`	`announce_function (fndecl);`

`if (DECL_CONTEXT (fndecl) == NULL_TREE)`	`if (DECL_CONTEXT (fndecl) == NULL_TREE)`
`{`	`{`
`/* Create RTL for function declaration. */`	`/* Create RTL for function declaration. */`
`rest_of_decl_compilation (fndecl, 1, 0);`	`rest_of_decl_compilation (fndecl, 1, 0);`
`}`	`}`

`/* Create RTL for function definition. */`	`/* Create RTL for function definition. */`
`make_decl_rtl (fndecl);`	`make_decl_rtl (fndecl);`

`init_function_start (fndecl);`	`init_function_start (fndecl);`

`/* Even though we're inside a function body, we still don't want to`	`/* Even though we're inside a function body, we still don't want to`
`call expand_expr to calculate the size of a variable-sized array.`	`call expand_expr to calculate the size of a variable-sized array.`
`We haven't necessarily assigned RTL to all variables yet, so it's`	`We haven't necessarily assigned RTL to all variables yet, so it's`
`not safe to try to expand expressions involving them. */`	`not safe to try to expand expressions involving them. */`
`cfun->dont_save_pending_sizes_p = 1;`	`cfun->dont_save_pending_sizes_p = 1;`

`/* function.c requires a push at the start of the function. */`	`/* function.c requires a push at the start of the function. */`
`pushlevel (0);`	`pushlevel (0);`
`}`	`}`

`/* Create thunks for alternate entry points. */`	`/* Create thunks for alternate entry points. */`

`static void`	`static void`
`build_entry_thunks (gfc_namespace * ns)`	`build_entry_thunks (gfc_namespace * ns)`
`{`	`{`
`gfc_formal_arglist *formal;`	`gfc_formal_arglist *formal;`
`gfc_formal_arglist *thunk_formal;`	`gfc_formal_arglist *thunk_formal;`
`gfc_entry_list *el;`	`gfc_entry_list *el;`
`gfc_symbol *thunk_sym;`	`gfc_symbol *thunk_sym;`
`stmtblock_t body;`	`stmtblock_t body;`
`tree thunk_fndecl;`	`tree thunk_fndecl;`
`tree args;`	`tree args;`
`tree string_args;`	`tree string_args;`
`tree tmp;`	`tree tmp;`
`locus old_loc;`	`locus old_loc;`

`/* This should always be a toplevel function. */`	`/* This should always be a toplevel function. */`
`gcc_assert (current_function_decl == NULL_TREE);`	`gcc_assert (current_function_decl == NULL_TREE);`

`gfc_get_backend_locus (&old_loc);`	`gfc_get_backend_locus (&old_loc);`
`for (el = ns->entries; el; el = el->next)`	`for (el = ns->entries; el; el = el->next)`
`{`	`{`
`thunk_sym = el->sym;`	`thunk_sym = el->sym;`

`build_function_decl (thunk_sym);`	`build_function_decl (thunk_sym);`
`create_function_arglist (thunk_sym);`	`create_function_arglist (thunk_sym);`

`trans_function_start (thunk_sym);`	`trans_function_start (thunk_sym);`

`thunk_fndecl = thunk_sym->backend_decl;`	`thunk_fndecl = thunk_sym->backend_decl;`

`gfc_init_block (&body);`	`gfc_init_block (&body);`

`/* Pass extra parameter identifying this entry point. */`	`/* Pass extra parameter identifying this entry point. */`
`tmp = build_int_cst (gfc_array_index_type, el->id);`	`tmp = build_int_cst (gfc_array_index_type, el->id);`
`args = tree_cons (NULL_TREE, tmp, NULL_TREE);`	`args = tree_cons (NULL_TREE, tmp, NULL_TREE);`
`string_args = NULL_TREE;`	`string_args = NULL_TREE;`

`if (thunk_sym->attr.function)`	`if (thunk_sym->attr.function)`
`{`	`{`
`if (gfc_return_by_reference (ns->proc_name))`	`if (gfc_return_by_reference (ns->proc_name))`
`{`	`{`
`tree ref = DECL_ARGUMENTS (current_function_decl);`	`tree ref = DECL_ARGUMENTS (current_function_decl);`
`args = tree_cons (NULL_TREE, ref, args);`	`args = tree_cons (NULL_TREE, ref, args);`
`if (ns->proc_name->ts.type == BT_CHARACTER)`	`if (ns->proc_name->ts.type == BT_CHARACTER)`
`args = tree_cons (NULL_TREE, TREE_CHAIN (ref),`	`args = tree_cons (NULL_TREE, TREE_CHAIN (ref),`
`args);`	`args);`
`}`	`}`
`}`	`}`

`for (formal = ns->proc_name->formal; formal; formal = formal->next)`	`for (formal = ns->proc_name->formal; formal; formal = formal->next)`
`{`	`{`
`/* Ignore alternate returns. */`	`/* Ignore alternate returns. */`
`if (formal->sym == NULL)`	`if (formal->sym == NULL)`
`continue;`	`continue;`

`/* We don't have a clever way of identifying arguments, so resort to`	`/* We don't have a clever way of identifying arguments, so resort to`
`a brute-force search. */`	`a brute-force search. */`
`for (thunk_formal = thunk_sym->formal;`	`for (thunk_formal = thunk_sym->formal;`
`thunk_formal;`	`thunk_formal;`
`thunk_formal = thunk_formal->next)`	`thunk_formal = thunk_formal->next)`
`{`	`{`
`if (thunk_formal->sym == formal->sym)`	`if (thunk_formal->sym == formal->sym)`
`break;`	`break;`
`}`	`}`

`if (thunk_formal)`	`if (thunk_formal)`
`{`	`{`
`/* Pass the argument. */`	`/* Pass the argument. */`
`DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;`	`DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;`
`args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,`	`args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,`
`args);`	`args);`
`if (formal->sym->ts.type == BT_CHARACTER)`	`if (formal->sym->ts.type == BT_CHARACTER)`
`{`	`{`
`tmp = thunk_formal->sym->ts.u.cl->backend_decl;`	`tmp = thunk_formal->sym->ts.u.cl->backend_decl;`
`string_args = tree_cons (NULL_TREE, tmp, string_args);`	`string_args = tree_cons (NULL_TREE, tmp, string_args);`
`}`	`}`
`}`	`}`
`else`	`else`
`{`	`{`
`/* Pass NULL for a missing argument. */`	`/* Pass NULL for a missing argument. */`
`args = tree_cons (NULL_TREE, null_pointer_node, args);`	`args = tree_cons (NULL_TREE, null_pointer_node, args);`
`if (formal->sym->ts.type == BT_CHARACTER)`	`if (formal->sym->ts.type == BT_CHARACTER)`
`{`	`{`
`tmp = build_int_cst (gfc_charlen_type_node, 0);`	`tmp = build_int_cst (gfc_charlen_type_node, 0);`
`string_args = tree_cons (NULL_TREE, tmp, string_args);`	`string_args = tree_cons (NULL_TREE, tmp, string_args);`
`}`	`}`
`}`	`}`
`}`	`}`

`/* Call the master function. */`	`/* Call the master function. */`
`args = nreverse (args);`	`args = nreverse (args);`
`args = chainon (args, nreverse (string_args));`	`args = chainon (args, nreverse (string_args));`
`tmp = ns->proc_name->backend_decl;`	`tmp = ns->proc_name->backend_decl;`
`tmp = build_function_call_expr (input_location, tmp, args);`	`tmp = build_function_call_expr (input_location, tmp, args);`
`if (ns->proc_name->attr.mixed_entry_master)`	`if (ns->proc_name->attr.mixed_entry_master)`
`{`	`{`
`tree union_decl, field;`	`tree union_decl, field;`
`tree master_type = TREE_TYPE (ns->proc_name->backend_decl);`	`tree master_type = TREE_TYPE (ns->proc_name->backend_decl);`

`union_decl = build_decl (input_location,`	`union_decl = build_decl (input_location,`
`VAR_DECL, get_identifier ("__result"),`	`VAR_DECL, get_identifier ("__result"),`
`TREE_TYPE (master_type));`	`TREE_TYPE (master_type));`
`DECL_ARTIFICIAL (union_decl) = 1;`	`DECL_ARTIFICIAL (union_decl) = 1;`
`DECL_EXTERNAL (union_decl) = 0;`	`DECL_EXTERNAL (union_decl) = 0;`
`TREE_PUBLIC (union_decl) = 0;`	`TREE_PUBLIC (union_decl) = 0;`
`TREE_USED (union_decl) = 1;`	`TREE_USED (union_decl) = 1;`
`layout_decl (union_decl, 0);`	`layout_decl (union_decl, 0);`
`pushdecl (union_decl);`	`pushdecl (union_decl);`

`DECL_CONTEXT (union_decl) = current_function_decl;`	`DECL_CONTEXT (union_decl) = current_function_decl;`
`tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),`	`tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),`
`union_decl, tmp);`	`union_decl, tmp);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`

`for (field = TYPE_FIELDS (TREE_TYPE (union_decl));`	`for (field = TYPE_FIELDS (TREE_TYPE (union_decl));`
`field; field = TREE_CHAIN (field))`	`field; field = TREE_CHAIN (field))`
`if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),`	`if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),`
`thunk_sym->result->name) == 0)`	`thunk_sym->result->name) == 0)`
`break;`	`break;`
`gcc_assert (field != NULL_TREE);`	`gcc_assert (field != NULL_TREE);`
`tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),`	`tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),`
`union_decl, field, NULL_TREE);`	`union_decl, field, NULL_TREE);`
`tmp = fold_build2 (MODIFY_EXPR,`	`tmp = fold_build2 (MODIFY_EXPR,`
`TREE_TYPE (DECL_RESULT (current_function_decl)),`	`TREE_TYPE (DECL_RESULT (current_function_decl)),`
`DECL_RESULT (current_function_decl), tmp);`	`DECL_RESULT (current_function_decl), tmp);`
`tmp = build1_v (RETURN_EXPR, tmp);`	`tmp = build1_v (RETURN_EXPR, tmp);`
`}`	`}`
`else if (TREE_TYPE (DECL_RESULT (current_function_decl))`	`else if (TREE_TYPE (DECL_RESULT (current_function_decl))`
`!= void_type_node)`	`!= void_type_node)`
`{`	`{`
`tmp = fold_build2 (MODIFY_EXPR,`	`tmp = fold_build2 (MODIFY_EXPR,`
`TREE_TYPE (DECL_RESULT (current_function_decl)),`	`TREE_TYPE (DECL_RESULT (current_function_decl)),`
`DECL_RESULT (current_function_decl), tmp);`	`DECL_RESULT (current_function_decl), tmp);`
`tmp = build1_v (RETURN_EXPR, tmp);`	`tmp = build1_v (RETURN_EXPR, tmp);`
`}`	`}`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`

`/* Finish off this function and send it for code generation. */`	`/* Finish off this function and send it for code generation. */`
`DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);`	`DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);`
`tmp = getdecls ();`	`tmp = getdecls ();`
`poplevel (1, 0, 1);`	`poplevel (1, 0, 1);`
`BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;`	`BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;`
`DECL_SAVED_TREE (thunk_fndecl)`	`DECL_SAVED_TREE (thunk_fndecl)`
`= build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),`	`= build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),`
`DECL_INITIAL (thunk_fndecl));`	`DECL_INITIAL (thunk_fndecl));`

`/* Output the GENERIC tree. */`	`/* Output the GENERIC tree. */`
`dump_function (TDI_original, thunk_fndecl);`	`dump_function (TDI_original, thunk_fndecl);`

`/* Store the end of the function, so that we get good line number`	`/* Store the end of the function, so that we get good line number`
`info for the epilogue. */`	`info for the epilogue. */`
`cfun->function_end_locus = input_location;`	`cfun->function_end_locus = input_location;`

`/* We're leaving the context of this function, so zap cfun.`	`/* We're leaving the context of this function, so zap cfun.`
`It's still in DECL_STRUCT_FUNCTION, and we'll restore it in`	`It's still in DECL_STRUCT_FUNCTION, and we'll restore it in`
`tree_rest_of_compilation. */`	`tree_rest_of_compilation. */`
`set_cfun (NULL);`	`set_cfun (NULL);`

`current_function_decl = NULL_TREE;`	`current_function_decl = NULL_TREE;`

`cgraph_finalize_function (thunk_fndecl, true);`	`cgraph_finalize_function (thunk_fndecl, true);`

`/* We share the symbols in the formal argument list with other entry`	`/* We share the symbols in the formal argument list with other entry`
`points and the master function. Clear them so that they are`	`points and the master function. Clear them so that they are`
`recreated for each function. */`	`recreated for each function. */`
`for (formal = thunk_sym->formal; formal; formal = formal->next)`	`for (formal = thunk_sym->formal; formal; formal = formal->next)`
`if (formal->sym != NULL) /* Ignore alternate returns. */`	`if (formal->sym != NULL) /* Ignore alternate returns. */`
`{`	`{`
`formal->sym->backend_decl = NULL_TREE;`	`formal->sym->backend_decl = NULL_TREE;`
`if (formal->sym->ts.type == BT_CHARACTER)`	`if (formal->sym->ts.type == BT_CHARACTER)`
`formal->sym->ts.u.cl->backend_decl = NULL_TREE;`	`formal->sym->ts.u.cl->backend_decl = NULL_TREE;`
`}`	`}`

`if (thunk_sym->attr.function)`	`if (thunk_sym->attr.function)`
`{`	`{`
`if (thunk_sym->ts.type == BT_CHARACTER)`	`if (thunk_sym->ts.type == BT_CHARACTER)`
`thunk_sym->ts.u.cl->backend_decl = NULL_TREE;`	`thunk_sym->ts.u.cl->backend_decl = NULL_TREE;`
`if (thunk_sym->result->ts.type == BT_CHARACTER)`	`if (thunk_sym->result->ts.type == BT_CHARACTER)`
`thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;`	`thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;`
`}`	`}`
`}`	`}`

`gfc_set_backend_locus (&old_loc);`	`gfc_set_backend_locus (&old_loc);`
`}`	`}`


`/* Create a decl for a function, and create any thunks for alternate entry`	`/* Create a decl for a function, and create any thunks for alternate entry`
`points. */`	`points. */`

`void`	`void`
`gfc_create_function_decl (gfc_namespace * ns)`	`gfc_create_function_decl (gfc_namespace * ns)`
`{`	`{`
`/* Create a declaration for the master function. */`	`/* Create a declaration for the master function. */`
`build_function_decl (ns->proc_name);`	`build_function_decl (ns->proc_name);`

`/* Compile the entry thunks. */`	`/* Compile the entry thunks. */`
`if (ns->entries)`	`if (ns->entries)`
`build_entry_thunks (ns);`	`build_entry_thunks (ns);`

`/* Now create the read argument list. */`	`/* Now create the read argument list. */`
`create_function_arglist (ns->proc_name);`	`create_function_arglist (ns->proc_name);`
`}`	`}`

`/* Return the decl used to hold the function return value. If`	`/* Return the decl used to hold the function return value. If`
`parent_flag is set, the context is the parent_scope. */`	`parent_flag is set, the context is the parent_scope. */`

`tree`	`tree`
`gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)`	`gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)`
`{`	`{`
`tree decl;`	`tree decl;`
`tree length;`	`tree length;`
`tree this_fake_result_decl;`	`tree this_fake_result_decl;`
`tree this_function_decl;`	`tree this_function_decl;`

`char name[GFC_MAX_SYMBOL_LEN + 10];`	`char name[GFC_MAX_SYMBOL_LEN + 10];`

`if (parent_flag)`	`if (parent_flag)`
`{`	`{`
`this_fake_result_decl = parent_fake_result_decl;`	`this_fake_result_decl = parent_fake_result_decl;`
`this_function_decl = DECL_CONTEXT (current_function_decl);`	`this_function_decl = DECL_CONTEXT (current_function_decl);`
`}`	`}`
`else`	`else`
`{`	`{`
`this_fake_result_decl = current_fake_result_decl;`	`this_fake_result_decl = current_fake_result_decl;`
`this_function_decl = current_function_decl;`	`this_function_decl = current_function_decl;`
`}`	`}`

`if (sym`	`if (sym`
`&& sym->ns->proc_name->backend_decl == this_function_decl`	`&& sym->ns->proc_name->backend_decl == this_function_decl`
`&& sym->ns->proc_name->attr.entry_master`	`&& sym->ns->proc_name->attr.entry_master`
`&& sym != sym->ns->proc_name)`	`&& sym != sym->ns->proc_name)`
`{`	`{`
`tree t = NULL, var;`	`tree t = NULL, var;`
`if (this_fake_result_decl != NULL)`	`if (this_fake_result_decl != NULL)`
`for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))`	`for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))`
`if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)`	`if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)`
`break;`	`break;`
`if (t)`	`if (t)`
`return TREE_VALUE (t);`	`return TREE_VALUE (t);`
`decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);`	`decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);`

`if (parent_flag)`	`if (parent_flag)`
`this_fake_result_decl = parent_fake_result_decl;`	`this_fake_result_decl = parent_fake_result_decl;`
`else`	`else`
`this_fake_result_decl = current_fake_result_decl;`	`this_fake_result_decl = current_fake_result_decl;`

`if (decl && sym->ns->proc_name->attr.mixed_entry_master)`	`if (decl && sym->ns->proc_name->attr.mixed_entry_master)`
`{`	`{`
`tree field;`	`tree field;`

`for (field = TYPE_FIELDS (TREE_TYPE (decl));`	`for (field = TYPE_FIELDS (TREE_TYPE (decl));`
`field; field = TREE_CHAIN (field))`	`field; field = TREE_CHAIN (field))`
`if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),`	`if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),`
`sym->name) == 0)`	`sym->name) == 0)`
`break;`	`break;`

`gcc_assert (field != NULL_TREE);`	`gcc_assert (field != NULL_TREE);`
`decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),`	`decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),`
`decl, field, NULL_TREE);`	`decl, field, NULL_TREE);`
`}`	`}`

`var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);`	`var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);`
`if (parent_flag)`	`if (parent_flag)`
`gfc_add_decl_to_parent_function (var);`	`gfc_add_decl_to_parent_function (var);`
`else`	`else`
`gfc_add_decl_to_function (var);`	`gfc_add_decl_to_function (var);`

`SET_DECL_VALUE_EXPR (var, decl);`	`SET_DECL_VALUE_EXPR (var, decl);`
`DECL_HAS_VALUE_EXPR_P (var) = 1;`	`DECL_HAS_VALUE_EXPR_P (var) = 1;`
`GFC_DECL_RESULT (var) = 1;`	`GFC_DECL_RESULT (var) = 1;`

`TREE_CHAIN (this_fake_result_decl)`	`TREE_CHAIN (this_fake_result_decl)`
`= tree_cons (get_identifier (sym->name), var,`	`= tree_cons (get_identifier (sym->name), var,`
`TREE_CHAIN (this_fake_result_decl));`	`TREE_CHAIN (this_fake_result_decl));`
`return var;`	`return var;`
`}`	`}`

`if (this_fake_result_decl != NULL_TREE)`	`if (this_fake_result_decl != NULL_TREE)`
`return TREE_VALUE (this_fake_result_decl);`	`return TREE_VALUE (this_fake_result_decl);`

`/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,`	`/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,`
`sym is NULL. */`	`sym is NULL. */`
`if (!sym)`	`if (!sym)`
`return NULL_TREE;`	`return NULL_TREE;`

`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`{`	`{`
`if (sym->ts.u.cl->backend_decl == NULL_TREE)`	`if (sym->ts.u.cl->backend_decl == NULL_TREE)`
`length = gfc_create_string_length (sym);`	`length = gfc_create_string_length (sym);`
`else`	`else`
`length = sym->ts.u.cl->backend_decl;`	`length = sym->ts.u.cl->backend_decl;`
`if (TREE_CODE (length) == VAR_DECL`	`if (TREE_CODE (length) == VAR_DECL`
`&& DECL_CONTEXT (length) == NULL_TREE)`	`&& DECL_CONTEXT (length) == NULL_TREE)`
`gfc_add_decl_to_function (length);`	`gfc_add_decl_to_function (length);`
`}`	`}`

`if (gfc_return_by_reference (sym))`	`if (gfc_return_by_reference (sym))`
`{`	`{`
`decl = DECL_ARGUMENTS (this_function_decl);`	`decl = DECL_ARGUMENTS (this_function_decl);`

`if (sym->ns->proc_name->backend_decl == this_function_decl`	`if (sym->ns->proc_name->backend_decl == this_function_decl`
`&& sym->ns->proc_name->attr.entry_master)`	`&& sym->ns->proc_name->attr.entry_master)`
`decl = TREE_CHAIN (decl);`	`decl = TREE_CHAIN (decl);`

`TREE_USED (decl) = 1;`	`TREE_USED (decl) = 1;`
`if (sym->as)`	`if (sym->as)`
`decl = gfc_build_dummy_array_decl (sym, decl);`	`decl = gfc_build_dummy_array_decl (sym, decl);`
`}`	`}`
`else`	`else`
`{`	`{`
`sprintf (name, "__result_%.20s",`	`sprintf (name, "__result_%.20s",`
`IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));`	`IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));`

`if (!sym->attr.mixed_entry_master && sym->attr.function)`	`if (!sym->attr.mixed_entry_master && sym->attr.function)`
`decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),`	`decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),`
`VAR_DECL, get_identifier (name),`	`VAR_DECL, get_identifier (name),`
`gfc_sym_type (sym));`	`gfc_sym_type (sym));`
`else`	`else`
`decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),`	`decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),`
`VAR_DECL, get_identifier (name),`	`VAR_DECL, get_identifier (name),`
`TREE_TYPE (TREE_TYPE (this_function_decl)));`	`TREE_TYPE (TREE_TYPE (this_function_decl)));`
`DECL_ARTIFICIAL (decl) = 1;`	`DECL_ARTIFICIAL (decl) = 1;`
`DECL_EXTERNAL (decl) = 0;`	`DECL_EXTERNAL (decl) = 0;`
`TREE_PUBLIC (decl) = 0;`	`TREE_PUBLIC (decl) = 0;`
`TREE_USED (decl) = 1;`	`TREE_USED (decl) = 1;`
`GFC_DECL_RESULT (decl) = 1;`	`GFC_DECL_RESULT (decl) = 1;`
`TREE_ADDRESSABLE (decl) = 1;`	`TREE_ADDRESSABLE (decl) = 1;`

`layout_decl (decl, 0);`	`layout_decl (decl, 0);`

`if (parent_flag)`	`if (parent_flag)`
`gfc_add_decl_to_parent_function (decl);`	`gfc_add_decl_to_parent_function (decl);`
`else`	`else`
`gfc_add_decl_to_function (decl);`	`gfc_add_decl_to_function (decl);`
`}`	`}`

`if (parent_flag)`	`if (parent_flag)`
`parent_fake_result_decl = build_tree_list (NULL, decl);`	`parent_fake_result_decl = build_tree_list (NULL, decl);`
`else`	`else`
`current_fake_result_decl = build_tree_list (NULL, decl);`	`current_fake_result_decl = build_tree_list (NULL, decl);`

`return decl;`	`return decl;`
`}`	`}`


`/* Builds a function decl. The remaining parameters are the types of the`	`/* Builds a function decl. The remaining parameters are the types of the`
`function arguments. Negative nargs indicates a varargs function. */`	`function arguments. Negative nargs indicates a varargs function. */`

`tree`	`tree`
`gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)`	`gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)`
`{`	`{`
`tree arglist;`	`tree arglist;`
`tree argtype;`	`tree argtype;`
`tree fntype;`	`tree fntype;`
`tree fndecl;`	`tree fndecl;`
`va_list p;`	`va_list p;`
`int n;`	`int n;`

`/* Library functions must be declared with global scope. */`	`/* Library functions must be declared with global scope. */`
`gcc_assert (current_function_decl == NULL_TREE);`	`gcc_assert (current_function_decl == NULL_TREE);`

`va_start (p, nargs);`	`va_start (p, nargs);`


`/* Create a list of the argument types. */`	`/* Create a list of the argument types. */`
`for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)`	`for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)`
`{`	`{`
`argtype = va_arg (p, tree);`	`argtype = va_arg (p, tree);`
`arglist = gfc_chainon_list (arglist, argtype);`	`arglist = gfc_chainon_list (arglist, argtype);`
`}`	`}`

`if (nargs >= 0)`	`if (nargs >= 0)`
`{`	`{`
`/* Terminate the list. */`	`/* Terminate the list. */`
`arglist = gfc_chainon_list (arglist, void_type_node);`	`arglist = gfc_chainon_list (arglist, void_type_node);`
`}`	`}`

`/* Build the function type and decl. */`	`/* Build the function type and decl. */`
`fntype = build_function_type (rettype, arglist);`	`fntype = build_function_type (rettype, arglist);`
`fndecl = build_decl (input_location,`	`fndecl = build_decl (input_location,`
`FUNCTION_DECL, name, fntype);`	`FUNCTION_DECL, name, fntype);`

`/* Mark this decl as external. */`	`/* Mark this decl as external. */`
`DECL_EXTERNAL (fndecl) = 1;`	`DECL_EXTERNAL (fndecl) = 1;`
`TREE_PUBLIC (fndecl) = 1;`	`TREE_PUBLIC (fndecl) = 1;`

`va_end (p);`	`va_end (p);`

`pushdecl (fndecl);`	`pushdecl (fndecl);`

`rest_of_decl_compilation (fndecl, 1, 0);`	`rest_of_decl_compilation (fndecl, 1, 0);`

`return fndecl;`	`return fndecl;`
`}`	`}`

`static void`	`static void`
`gfc_build_intrinsic_function_decls (void)`	`gfc_build_intrinsic_function_decls (void)`
`{`	`{`
`tree gfc_int4_type_node = gfc_get_int_type (4);`	`tree gfc_int4_type_node = gfc_get_int_type (4);`
`tree gfc_int8_type_node = gfc_get_int_type (8);`	`tree gfc_int8_type_node = gfc_get_int_type (8);`
`tree gfc_int16_type_node = gfc_get_int_type (16);`	`tree gfc_int16_type_node = gfc_get_int_type (16);`
`tree gfc_logical4_type_node = gfc_get_logical_type (4);`	`tree gfc_logical4_type_node = gfc_get_logical_type (4);`
`tree pchar1_type_node = gfc_get_pchar_type (1);`	`tree pchar1_type_node = gfc_get_pchar_type (1);`
`tree pchar4_type_node = gfc_get_pchar_type (4);`	`tree pchar4_type_node = gfc_get_pchar_type (4);`

`/* String functions. */`	`/* String functions. */`
`gfor_fndecl_compare_string =`	`gfor_fndecl_compare_string =`
`gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),`
`integer_type_node, 4,`	`integer_type_node, 4,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_charlen_type_node, pchar1_type_node);`	`gfc_charlen_type_node, pchar1_type_node);`

`gfor_fndecl_concat_string =`	`gfor_fndecl_concat_string =`
`gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),`
`void_type_node, 6,`	`void_type_node, 6,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_charlen_type_node, pchar1_type_node);`	`gfc_charlen_type_node, pchar1_type_node);`

`gfor_fndecl_string_len_trim =`	`gfor_fndecl_string_len_trim =`
`gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),`
`gfc_int4_type_node, 2,`	`gfc_int4_type_node, 2,`
`gfc_charlen_type_node, pchar1_type_node);`	`gfc_charlen_type_node, pchar1_type_node);`

`gfor_fndecl_string_index =`	`gfor_fndecl_string_index =`
`gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),`
`gfc_int4_type_node, 5,`	`gfc_int4_type_node, 5,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_logical4_type_node);`	`gfc_logical4_type_node);`

`gfor_fndecl_string_scan =`	`gfor_fndecl_string_scan =`
`gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),`
`gfc_int4_type_node, 5,`	`gfc_int4_type_node, 5,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_logical4_type_node);`	`gfc_logical4_type_node);`

`gfor_fndecl_string_verify =`	`gfor_fndecl_string_verify =`
`gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),`
`gfc_int4_type_node, 5,`	`gfc_int4_type_node, 5,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_charlen_type_node, pchar1_type_node,`	`gfc_charlen_type_node, pchar1_type_node,`
`gfc_logical4_type_node);`	`gfc_logical4_type_node);`

`gfor_fndecl_string_trim =`	`gfor_fndecl_string_trim =`
`gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),`
`void_type_node, 4,`	`void_type_node, 4,`
`build_pointer_type (gfc_charlen_type_node),`	`build_pointer_type (gfc_charlen_type_node),`
`build_pointer_type (pchar1_type_node),`	`build_pointer_type (pchar1_type_node),`
`gfc_charlen_type_node, pchar1_type_node);`	`gfc_charlen_type_node, pchar1_type_node);`

`gfor_fndecl_string_minmax =`	`gfor_fndecl_string_minmax =`
`gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),`
`void_type_node, -4,`	`void_type_node, -4,`
`build_pointer_type (gfc_charlen_type_node),`	`build_pointer_type (gfc_charlen_type_node),`
`build_pointer_type (pchar1_type_node),`	`build_pointer_type (pchar1_type_node),`
`integer_type_node, integer_type_node);`	`integer_type_node, integer_type_node);`

`gfor_fndecl_adjustl =`	`gfor_fndecl_adjustl =`
`gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),`
`void_type_node, 3, pchar1_type_node,`	`void_type_node, 3, pchar1_type_node,`
`gfc_charlen_type_node, pchar1_type_node);`	`gfc_charlen_type_node, pchar1_type_node);`

`gfor_fndecl_adjustr =`	`gfor_fndecl_adjustr =`
`gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),`
`void_type_node, 3, pchar1_type_node,`	`void_type_node, 3, pchar1_type_node,`
`gfc_charlen_type_node, pchar1_type_node);`	`gfc_charlen_type_node, pchar1_type_node);`

`gfor_fndecl_select_string =`	`gfor_fndecl_select_string =`
`gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),`
`integer_type_node, 4, pvoid_type_node,`	`integer_type_node, 4, pvoid_type_node,`
`integer_type_node, pchar1_type_node,`	`integer_type_node, pchar1_type_node,`
`gfc_charlen_type_node);`	`gfc_charlen_type_node);`

`gfor_fndecl_compare_string_char4 =`	`gfor_fndecl_compare_string_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("compare_string_char4")),`	`(PREFIX("compare_string_char4")),`
`integer_type_node, 4,`	`integer_type_node, 4,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_charlen_type_node, pchar4_type_node);`	`gfc_charlen_type_node, pchar4_type_node);`

`gfor_fndecl_concat_string_char4 =`	`gfor_fndecl_concat_string_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("concat_string_char4")),`	`(PREFIX("concat_string_char4")),`
`void_type_node, 6,`	`void_type_node, 6,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_charlen_type_node, pchar4_type_node);`	`gfc_charlen_type_node, pchar4_type_node);`

`gfor_fndecl_string_len_trim_char4 =`	`gfor_fndecl_string_len_trim_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("string_len_trim_char4")),`	`(PREFIX("string_len_trim_char4")),`
`gfc_charlen_type_node, 2,`	`gfc_charlen_type_node, 2,`
`gfc_charlen_type_node, pchar4_type_node);`	`gfc_charlen_type_node, pchar4_type_node);`

`gfor_fndecl_string_index_char4 =`	`gfor_fndecl_string_index_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("string_index_char4")),`	`(PREFIX("string_index_char4")),`
`gfc_charlen_type_node, 5,`	`gfc_charlen_type_node, 5,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_logical4_type_node);`	`gfc_logical4_type_node);`

`gfor_fndecl_string_scan_char4 =`	`gfor_fndecl_string_scan_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("string_scan_char4")),`	`(PREFIX("string_scan_char4")),`
`gfc_charlen_type_node, 5,`	`gfc_charlen_type_node, 5,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_logical4_type_node);`	`gfc_logical4_type_node);`

`gfor_fndecl_string_verify_char4 =`	`gfor_fndecl_string_verify_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("string_verify_char4")),`	`(PREFIX("string_verify_char4")),`
`gfc_charlen_type_node, 5,`	`gfc_charlen_type_node, 5,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_charlen_type_node, pchar4_type_node,`	`gfc_charlen_type_node, pchar4_type_node,`
`gfc_logical4_type_node);`	`gfc_logical4_type_node);`

`gfor_fndecl_string_trim_char4 =`	`gfor_fndecl_string_trim_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("string_trim_char4")),`	`(PREFIX("string_trim_char4")),`
`void_type_node, 4,`	`void_type_node, 4,`
`build_pointer_type (gfc_charlen_type_node),`	`build_pointer_type (gfc_charlen_type_node),`
`build_pointer_type (pchar4_type_node),`	`build_pointer_type (pchar4_type_node),`
`gfc_charlen_type_node, pchar4_type_node);`	`gfc_charlen_type_node, pchar4_type_node);`

`gfor_fndecl_string_minmax_char4 =`	`gfor_fndecl_string_minmax_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("string_minmax_char4")),`	`(PREFIX("string_minmax_char4")),`
`void_type_node, -4,`	`void_type_node, -4,`
`build_pointer_type (gfc_charlen_type_node),`	`build_pointer_type (gfc_charlen_type_node),`
`build_pointer_type (pchar4_type_node),`	`build_pointer_type (pchar4_type_node),`
`integer_type_node, integer_type_node);`	`integer_type_node, integer_type_node);`

`gfor_fndecl_adjustl_char4 =`	`gfor_fndecl_adjustl_char4 =`
`gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),`
`void_type_node, 3, pchar4_type_node,`	`void_type_node, 3, pchar4_type_node,`
`gfc_charlen_type_node, pchar4_type_node);`	`gfc_charlen_type_node, pchar4_type_node);`

`gfor_fndecl_adjustr_char4 =`	`gfor_fndecl_adjustr_char4 =`
`gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),`
`void_type_node, 3, pchar4_type_node,`	`void_type_node, 3, pchar4_type_node,`
`gfc_charlen_type_node, pchar4_type_node);`	`gfc_charlen_type_node, pchar4_type_node);`

`gfor_fndecl_select_string_char4 =`	`gfor_fndecl_select_string_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("select_string_char4")),`	`(PREFIX("select_string_char4")),`
`integer_type_node, 4, pvoid_type_node,`	`integer_type_node, 4, pvoid_type_node,`
`integer_type_node, pvoid_type_node,`	`integer_type_node, pvoid_type_node,`
`gfc_charlen_type_node);`	`gfc_charlen_type_node);`


`/* Conversion between character kinds. */`	`/* Conversion between character kinds. */`

`gfor_fndecl_convert_char1_to_char4 =`	`gfor_fndecl_convert_char1_to_char4 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("convert_char1_to_char4")),`	`(PREFIX("convert_char1_to_char4")),`
`void_type_node, 3,`	`void_type_node, 3,`
`build_pointer_type (pchar4_type_node),`	`build_pointer_type (pchar4_type_node),`
`gfc_charlen_type_node, pchar1_type_node);`	`gfc_charlen_type_node, pchar1_type_node);`

`gfor_fndecl_convert_char4_to_char1 =`	`gfor_fndecl_convert_char4_to_char1 =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("convert_char4_to_char1")),`	`(PREFIX("convert_char4_to_char1")),`
`void_type_node, 3,`	`void_type_node, 3,`
`build_pointer_type (pchar1_type_node),`	`build_pointer_type (pchar1_type_node),`
`gfc_charlen_type_node, pchar4_type_node);`	`gfc_charlen_type_node, pchar4_type_node);`

`/* Misc. functions. */`	`/* Misc. functions. */`

`gfor_fndecl_ttynam =`	`gfor_fndecl_ttynam =`
`gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),`
`void_type_node,`	`void_type_node,`
`3,`	`3,`
`pchar_type_node,`	`pchar_type_node,`
`gfc_charlen_type_node,`	`gfc_charlen_type_node,`
`integer_type_node);`	`integer_type_node);`

`gfor_fndecl_fdate =`	`gfor_fndecl_fdate =`
`gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),`
`void_type_node,`	`void_type_node,`
`2,`	`2,`
`pchar_type_node,`	`pchar_type_node,`
`gfc_charlen_type_node);`	`gfc_charlen_type_node);`

`gfor_fndecl_ctime =`	`gfor_fndecl_ctime =`
`gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),`
`void_type_node,`	`void_type_node,`
`3,`	`3,`
`pchar_type_node,`	`pchar_type_node,`
`gfc_charlen_type_node,`	`gfc_charlen_type_node,`
`gfc_int8_type_node);`	`gfc_int8_type_node);`

`gfor_fndecl_sc_kind =`	`gfor_fndecl_sc_kind =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("selected_char_kind")),`	`(PREFIX("selected_char_kind")),`
`gfc_int4_type_node, 2,`	`gfc_int4_type_node, 2,`
`gfc_charlen_type_node, pchar_type_node);`	`gfc_charlen_type_node, pchar_type_node);`

`gfor_fndecl_si_kind =`	`gfor_fndecl_si_kind =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("selected_int_kind")),`	`(PREFIX("selected_int_kind")),`
`gfc_int4_type_node, 1, pvoid_type_node);`	`gfc_int4_type_node, 1, pvoid_type_node);`

`gfor_fndecl_sr_kind =`	`gfor_fndecl_sr_kind =`
`gfc_build_library_function_decl (get_identifier`	`gfc_build_library_function_decl (get_identifier`
`(PREFIX("selected_real_kind")),`	`(PREFIX("selected_real_kind")),`
`gfc_int4_type_node, 2,`	`gfc_int4_type_node, 2,`
`pvoid_type_node, pvoid_type_node);`	`pvoid_type_node, pvoid_type_node);`

`/* Power functions. */`	`/* Power functions. */`
`{`	`{`
`tree ctype, rtype, itype, jtype;`	`tree ctype, rtype, itype, jtype;`
`int rkind, ikind, jkind;`	`int rkind, ikind, jkind;`
`#define NIKINDS 3`	`#define NIKINDS 3`
`#define NRKINDS 4`	`#define NRKINDS 4`
`static int ikinds[NIKINDS] = {4, 8, 16};`	`static int ikinds[NIKINDS] = {4, 8, 16};`
`static int rkinds[NRKINDS] = {4, 8, 10, 16};`	`static int rkinds[NRKINDS] = {4, 8, 10, 16};`
`char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */`	`char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */`

`for (ikind=0; ikind < NIKINDS; ikind++)`	`for (ikind=0; ikind < NIKINDS; ikind++)`
`{`	`{`
`itype = gfc_get_int_type (ikinds[ikind]);`	`itype = gfc_get_int_type (ikinds[ikind]);`

`for (jkind=0; jkind < NIKINDS; jkind++)`	`for (jkind=0; jkind < NIKINDS; jkind++)`
`{`	`{`
`jtype = gfc_get_int_type (ikinds[jkind]);`	`jtype = gfc_get_int_type (ikinds[jkind]);`
`if (itype && jtype)`	`if (itype && jtype)`
`{`	`{`
`sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],`	`sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],`
`ikinds[jkind]);`	`ikinds[jkind]);`
`gfor_fndecl_math_powi[jkind][ikind].integer =`	`gfor_fndecl_math_powi[jkind][ikind].integer =`
`gfc_build_library_function_decl (get_identifier (name),`	`gfc_build_library_function_decl (get_identifier (name),`
`jtype, 2, jtype, itype);`	`jtype, 2, jtype, itype);`
`TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;`	`TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;`
`}`	`}`
`}`	`}`

`for (rkind = 0; rkind < NRKINDS; rkind ++)`	`for (rkind = 0; rkind < NRKINDS; rkind ++)`
`{`	`{`
`rtype = gfc_get_real_type (rkinds[rkind]);`	`rtype = gfc_get_real_type (rkinds[rkind]);`
`if (rtype && itype)`	`if (rtype && itype)`
`{`	`{`
`sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],`	`sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],`
`ikinds[ikind]);`	`ikinds[ikind]);`
`gfor_fndecl_math_powi[rkind][ikind].real =`	`gfor_fndecl_math_powi[rkind][ikind].real =`
`gfc_build_library_function_decl (get_identifier (name),`	`gfc_build_library_function_decl (get_identifier (name),`
`rtype, 2, rtype, itype);`	`rtype, 2, rtype, itype);`
`TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;`	`TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;`
`}`	`}`

`ctype = gfc_get_complex_type (rkinds[rkind]);`	`ctype = gfc_get_complex_type (rkinds[rkind]);`
`if (ctype && itype)`	`if (ctype && itype)`
`{`	`{`
`sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],`	`sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],`
`ikinds[ikind]);`	`ikinds[ikind]);`
`gfor_fndecl_math_powi[rkind][ikind].cmplx =`	`gfor_fndecl_math_powi[rkind][ikind].cmplx =`
`gfc_build_library_function_decl (get_identifier (name),`	`gfc_build_library_function_decl (get_identifier (name),`
`ctype, 2,ctype, itype);`	`ctype, 2,ctype, itype);`
`TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;`	`TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;`
`}`	`}`
`}`	`}`
`}`	`}`
`#undef NIKINDS`	`#undef NIKINDS`
`#undef NRKINDS`	`#undef NRKINDS`
`}`	`}`

`gfor_fndecl_math_ishftc4 =`	`gfor_fndecl_math_ishftc4 =`
`gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),`
`gfc_int4_type_node,`	`gfc_int4_type_node,`
`3, gfc_int4_type_node,`	`3, gfc_int4_type_node,`
`gfc_int4_type_node, gfc_int4_type_node);`	`gfc_int4_type_node, gfc_int4_type_node);`
`gfor_fndecl_math_ishftc8 =`	`gfor_fndecl_math_ishftc8 =`
`gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),`
`gfc_int8_type_node,`	`gfc_int8_type_node,`
`3, gfc_int8_type_node,`	`3, gfc_int8_type_node,`
`gfc_int4_type_node, gfc_int4_type_node);`	`gfc_int4_type_node, gfc_int4_type_node);`
`if (gfc_int16_type_node)`	`if (gfc_int16_type_node)`
`gfor_fndecl_math_ishftc16 =`	`gfor_fndecl_math_ishftc16 =`
`gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),`
`gfc_int16_type_node, 3,`	`gfc_int16_type_node, 3,`
`gfc_int16_type_node,`	`gfc_int16_type_node,`
`gfc_int4_type_node,`	`gfc_int4_type_node,`
`gfc_int4_type_node);`	`gfc_int4_type_node);`

`/* BLAS functions. */`	`/* BLAS functions. */`
`{`	`{`
`tree pint = build_pointer_type (integer_type_node);`	`tree pint = build_pointer_type (integer_type_node);`
`tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));`	`tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));`
`tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));`	`tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));`
`tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));`	`tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));`
`tree pz = build_pointer_type`	`tree pz = build_pointer_type`
`(gfc_get_complex_type (gfc_default_double_kind));`	`(gfc_get_complex_type (gfc_default_double_kind));`

`gfor_fndecl_sgemm = gfc_build_library_function_decl`	`gfor_fndecl_sgemm = gfc_build_library_function_decl`
`(get_identifier`	`(get_identifier`
`(gfc_option.flag_underscoring ? "sgemm_"`	`(gfc_option.flag_underscoring ? "sgemm_"`
`: "sgemm"),`	`: "sgemm"),`
`void_type_node, 15, pchar_type_node,`	`void_type_node, 15, pchar_type_node,`
`pchar_type_node, pint, pint, pint, ps, ps, pint,`	`pchar_type_node, pint, pint, pint, ps, ps, pint,`
`ps, pint, ps, ps, pint, integer_type_node,`	`ps, pint, ps, ps, pint, integer_type_node,`
`integer_type_node);`	`integer_type_node);`
`gfor_fndecl_dgemm = gfc_build_library_function_decl`	`gfor_fndecl_dgemm = gfc_build_library_function_decl`
`(get_identifier`	`(get_identifier`
`(gfc_option.flag_underscoring ? "dgemm_"`	`(gfc_option.flag_underscoring ? "dgemm_"`
`: "dgemm"),`	`: "dgemm"),`
`void_type_node, 15, pchar_type_node,`	`void_type_node, 15, pchar_type_node,`
`pchar_type_node, pint, pint, pint, pd, pd, pint,`	`pchar_type_node, pint, pint, pint, pd, pd, pint,`
`pd, pint, pd, pd, pint, integer_type_node,`	`pd, pint, pd, pd, pint, integer_type_node,`
`integer_type_node);`	`integer_type_node);`
`gfor_fndecl_cgemm = gfc_build_library_function_decl`	`gfor_fndecl_cgemm = gfc_build_library_function_decl`
`(get_identifier`	`(get_identifier`
`(gfc_option.flag_underscoring ? "cgemm_"`	`(gfc_option.flag_underscoring ? "cgemm_"`
`: "cgemm"),`	`: "cgemm"),`
`void_type_node, 15, pchar_type_node,`	`void_type_node, 15, pchar_type_node,`
`pchar_type_node, pint, pint, pint, pc, pc, pint,`	`pchar_type_node, pint, pint, pint, pc, pc, pint,`
`pc, pint, pc, pc, pint, integer_type_node,`	`pc, pint, pc, pc, pint, integer_type_node,`
`integer_type_node);`	`integer_type_node);`
`gfor_fndecl_zgemm = gfc_build_library_function_decl`	`gfor_fndecl_zgemm = gfc_build_library_function_decl`
`(get_identifier`	`(get_identifier`
`(gfc_option.flag_underscoring ? "zgemm_"`	`(gfc_option.flag_underscoring ? "zgemm_"`
`: "zgemm"),`	`: "zgemm"),`
`void_type_node, 15, pchar_type_node,`	`void_type_node, 15, pchar_type_node,`
`pchar_type_node, pint, pint, pint, pz, pz, pint,`	`pchar_type_node, pint, pint, pint, pz, pz, pint,`
`pz, pint, pz, pz, pint, integer_type_node,`	`pz, pint, pz, pz, pint, integer_type_node,`
`integer_type_node);`	`integer_type_node);`
`}`	`}`

`/* Other functions. */`	`/* Other functions. */`
`gfor_fndecl_size0 =`	`gfor_fndecl_size0 =`
`gfc_build_library_function_decl (get_identifier (PREFIX("size0")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("size0")),`
`gfc_array_index_type,`	`gfc_array_index_type,`
`1, pvoid_type_node);`	`1, pvoid_type_node);`
`gfor_fndecl_size1 =`	`gfor_fndecl_size1 =`
`gfc_build_library_function_decl (get_identifier (PREFIX("size1")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("size1")),`
`gfc_array_index_type,`	`gfc_array_index_type,`
`2, pvoid_type_node,`	`2, pvoid_type_node,`
`gfc_array_index_type);`	`gfc_array_index_type);`

`gfor_fndecl_iargc =`	`gfor_fndecl_iargc =`
`gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),`	`gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),`
`gfc_int4_type_node,`	`gfc_int4_type_node,`
`0);`	`0);`

`if (gfc_type_for_size (128, true))`	`if (gfc_type_for_size (128, true))`
`{`	`{`
`tree uint128 = gfc_type_for_size (128, true);`	`tree uint128 = gfc_type_for_size (128, true);`

`gfor_fndecl_clz128 =`	`gfor_fndecl_clz128 =`
`gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),`	`gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),`
`integer_type_node, 1, uint128);`	`integer_type_node, 1, uint128);`

`gfor_fndecl_ctz128 =`	`gfor_fndecl_ctz128 =`
`gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),`	`gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),`
`integer_type_node, 1, uint128);`	`integer_type_node, 1, uint128);`
`}`	`}`
`}`	`}`


`/* Make prototypes for runtime library functions. */`	`/* Make prototypes for runtime library functions. */`

`void`	`void`
`gfc_build_builtin_function_decls (void)`	`gfc_build_builtin_function_decls (void)`
`{`	`{`
`tree gfc_int4_type_node = gfc_get_int_type (4);`	`tree gfc_int4_type_node = gfc_get_int_type (4);`

`gfor_fndecl_stop_numeric =`	`gfor_fndecl_stop_numeric =`
`gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),`
`void_type_node, 1, gfc_int4_type_node);`	`void_type_node, 1, gfc_int4_type_node);`
`/* Stop doesn't return. */`	`/* Stop doesn't return. */`
`TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;`	`TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;`

`gfor_fndecl_stop_string =`	`gfor_fndecl_stop_string =`
`gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),`
`void_type_node, 2, pchar_type_node,`	`void_type_node, 2, pchar_type_node,`
`gfc_int4_type_node);`	`gfc_int4_type_node);`
`/* Stop doesn't return. */`	`/* Stop doesn't return. */`
`TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;`	`TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;`

`gfor_fndecl_pause_numeric =`	`gfor_fndecl_pause_numeric =`
`gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),`
`void_type_node, 1, gfc_int4_type_node);`	`void_type_node, 1, gfc_int4_type_node);`

`gfor_fndecl_pause_string =`	`gfor_fndecl_pause_string =`
`gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),`
`void_type_node, 2, pchar_type_node,`	`void_type_node, 2, pchar_type_node,`
`gfc_int4_type_node);`	`gfc_int4_type_node);`

`gfor_fndecl_runtime_error =`	`gfor_fndecl_runtime_error =`
`gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),`
`void_type_node, -1, pchar_type_node);`	`void_type_node, -1, pchar_type_node);`
`/* The runtime_error function does not return. */`	`/* The runtime_error function does not return. */`
`TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;`	`TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;`

`gfor_fndecl_runtime_error_at =`	`gfor_fndecl_runtime_error_at =`
`gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),`
`void_type_node, -2, pchar_type_node,`	`void_type_node, -2, pchar_type_node,`
`pchar_type_node);`	`pchar_type_node);`
`/* The runtime_error_at function does not return. */`	`/* The runtime_error_at function does not return. */`
`TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;`	`TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;`

`gfor_fndecl_runtime_warning_at =`	`gfor_fndecl_runtime_warning_at =`
`gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),`
`void_type_node, -2, pchar_type_node,`	`void_type_node, -2, pchar_type_node,`
`pchar_type_node);`	`pchar_type_node);`
`gfor_fndecl_generate_error =`	`gfor_fndecl_generate_error =`
`gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),`
`void_type_node, 3, pvoid_type_node,`	`void_type_node, 3, pvoid_type_node,`
`integer_type_node, pchar_type_node);`	`integer_type_node, pchar_type_node);`

`gfor_fndecl_os_error =`	`gfor_fndecl_os_error =`
`gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),`
`void_type_node, 1, pchar_type_node);`	`void_type_node, 1, pchar_type_node);`
`/* The runtime_error function does not return. */`	`/* The runtime_error function does not return. */`
`TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;`	`TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;`

`gfor_fndecl_set_args =`	`gfor_fndecl_set_args =`
`gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),`
`void_type_node, 2, integer_type_node,`	`void_type_node, 2, integer_type_node,`
`build_pointer_type (pchar_type_node));`	`build_pointer_type (pchar_type_node));`

`gfor_fndecl_set_fpe =`	`gfor_fndecl_set_fpe =`
`gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),`
`void_type_node, 1, integer_type_node);`	`void_type_node, 1, integer_type_node);`

`/* Keep the array dimension in sync with the call, later in this file. */`	`/* Keep the array dimension in sync with the call, later in this file. */`
`gfor_fndecl_set_options =`	`gfor_fndecl_set_options =`
`gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),`
`void_type_node, 2, integer_type_node,`	`void_type_node, 2, integer_type_node,`
`build_pointer_type (integer_type_node));`	`build_pointer_type (integer_type_node));`

`gfor_fndecl_set_convert =`	`gfor_fndecl_set_convert =`
`gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),`
`void_type_node, 1, integer_type_node);`	`void_type_node, 1, integer_type_node);`

`gfor_fndecl_set_record_marker =`	`gfor_fndecl_set_record_marker =`
`gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),`
`void_type_node, 1, integer_type_node);`	`void_type_node, 1, integer_type_node);`

`gfor_fndecl_set_max_subrecord_length =`	`gfor_fndecl_set_max_subrecord_length =`
`gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),`	`gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),`
`void_type_node, 1, integer_type_node);`	`void_type_node, 1, integer_type_node);`

`gfor_fndecl_in_pack = gfc_build_library_function_decl (`	`gfor_fndecl_in_pack = gfc_build_library_function_decl (`
`get_identifier (PREFIX("internal_pack")),`	`get_identifier (PREFIX("internal_pack")),`
`pvoid_type_node, 1, pvoid_type_node);`	`pvoid_type_node, 1, pvoid_type_node);`

`gfor_fndecl_in_unpack = gfc_build_library_function_decl (`	`gfor_fndecl_in_unpack = gfc_build_library_function_decl (`
`get_identifier (PREFIX("internal_unpack")),`	`get_identifier (PREFIX("internal_unpack")),`
`void_type_node, 2, pvoid_type_node, pvoid_type_node);`	`void_type_node, 2, pvoid_type_node, pvoid_type_node);`

`gfor_fndecl_associated =`	`gfor_fndecl_associated =`
`gfc_build_library_function_decl (`	`gfc_build_library_function_decl (`
`get_identifier (PREFIX("associated")),`	`get_identifier (PREFIX("associated")),`
`integer_type_node, 2, ppvoid_type_node,`	`integer_type_node, 2, ppvoid_type_node,`
`ppvoid_type_node);`	`ppvoid_type_node);`

`gfc_build_intrinsic_function_decls ();`	`gfc_build_intrinsic_function_decls ();`
`gfc_build_intrinsic_lib_fndecls ();`	`gfc_build_intrinsic_lib_fndecls ();`
`gfc_build_io_library_fndecls ();`	`gfc_build_io_library_fndecls ();`
`}`	`}`


`/* Evaluate the length of dummy character variables. */`	`/* Evaluate the length of dummy character variables. */`

`static tree`	`static tree`
`gfc_trans_dummy_character (gfc_symbol sym, gfc_charlen cl, tree fnbody)`	`gfc_trans_dummy_character (gfc_symbol sym, gfc_charlen cl, tree fnbody)`
`{`	`{`
`stmtblock_t body;`	`stmtblock_t body;`

`gfc_finish_decl (cl->backend_decl);`	`gfc_finish_decl (cl->backend_decl);`

`gfc_start_block (&body);`	`gfc_start_block (&body);`

`/* Evaluate the string length expression. */`	`/* Evaluate the string length expression. */`
`gfc_conv_string_length (cl, NULL, &body);`	`gfc_conv_string_length (cl, NULL, &body);`

`gfc_trans_vla_type_sizes (sym, &body);`	`gfc_trans_vla_type_sizes (sym, &body);`

`gfc_add_expr_to_block (&body, fnbody);`	`gfc_add_expr_to_block (&body, fnbody);`
`return gfc_finish_block (&body);`	`return gfc_finish_block (&body);`
`}`	`}`


`/* Allocate and cleanup an automatic character variable. */`	`/* Allocate and cleanup an automatic character variable. */`

`static tree`	`static tree`
`gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)`	`gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)`
`{`	`{`
`stmtblock_t body;`	`stmtblock_t body;`
`tree decl;`	`tree decl;`
`tree tmp;`	`tree tmp;`

`gcc_assert (sym->backend_decl);`	`gcc_assert (sym->backend_decl);`
`gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);`	`gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);`

`gfc_start_block (&body);`	`gfc_start_block (&body);`

`/* Evaluate the string length expression. */`	`/* Evaluate the string length expression. */`
`gfc_conv_string_length (sym->ts.u.cl, NULL, &body);`	`gfc_conv_string_length (sym->ts.u.cl, NULL, &body);`

`gfc_trans_vla_type_sizes (sym, &body);`	`gfc_trans_vla_type_sizes (sym, &body);`

`decl = sym->backend_decl;`	`decl = sym->backend_decl;`

`/* Emit a DECL_EXPR for this variable, which will cause the`	`/* Emit a DECL_EXPR for this variable, which will cause the`
`gimplifier to allocate storage, and all that good stuff. */`	`gimplifier to allocate storage, and all that good stuff. */`
`tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);`	`tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`

`gfc_add_expr_to_block (&body, fnbody);`	`gfc_add_expr_to_block (&body, fnbody);`
`return gfc_finish_block (&body);`	`return gfc_finish_block (&body);`
`}`	`}`

`/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */`	`/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */`

`static tree`	`static tree`
`gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)`	`gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)`
`{`	`{`
`stmtblock_t body;`	`stmtblock_t body;`

`gcc_assert (sym->backend_decl);`	`gcc_assert (sym->backend_decl);`
`gfc_start_block (&body);`	`gfc_start_block (&body);`

`/* Set the initial value to length. See the comments in`	`/* Set the initial value to length. See the comments in`
`function gfc_add_assign_aux_vars in this file. */`	`function gfc_add_assign_aux_vars in this file. */`
`gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),`	`gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),`
`build_int_cst (NULL_TREE, -2));`	`build_int_cst (NULL_TREE, -2));`

`gfc_add_expr_to_block (&body, fnbody);`	`gfc_add_expr_to_block (&body, fnbody);`
`return gfc_finish_block (&body);`	`return gfc_finish_block (&body);`
`}`	`}`

`static void`	`static void`
`gfc_trans_vla_one_sizepos (tree tp, stmtblock_t body)`	`gfc_trans_vla_one_sizepos (tree tp, stmtblock_t body)`
`{`	`{`
`tree t = *tp, var, val;`	`tree t = *tp, var, val;`

`if (t == NULL \|\| t == error_mark_node)`	`if (t == NULL \|\| t == error_mark_node)`
`return;`	`return;`
`if (TREE_CONSTANT (t) \|\| DECL_P (t))`	`if (TREE_CONSTANT (t) \|\| DECL_P (t))`
`return;`	`return;`

`if (TREE_CODE (t) == SAVE_EXPR)`	`if (TREE_CODE (t) == SAVE_EXPR)`
`{`	`{`
`if (SAVE_EXPR_RESOLVED_P (t))`	`if (SAVE_EXPR_RESOLVED_P (t))`
`{`	`{`
`*tp = TREE_OPERAND (t, 0);`	`*tp = TREE_OPERAND (t, 0);`
`return;`	`return;`
`}`	`}`
`val = TREE_OPERAND (t, 0);`	`val = TREE_OPERAND (t, 0);`
`}`	`}`
`else`	`else`
`val = t;`	`val = t;`

`var = gfc_create_var_np (TREE_TYPE (t), NULL);`	`var = gfc_create_var_np (TREE_TYPE (t), NULL);`
`gfc_add_decl_to_function (var);`	`gfc_add_decl_to_function (var);`
`gfc_add_modify (body, var, val);`	`gfc_add_modify (body, var, val);`
`if (TREE_CODE (t) == SAVE_EXPR)`	`if (TREE_CODE (t) == SAVE_EXPR)`
`TREE_OPERAND (t, 0) = var;`	`TREE_OPERAND (t, 0) = var;`
`*tp = var;`	`*tp = var;`
`}`	`}`

`static void`	`static void`
`gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)`	`gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)`
`{`	`{`
`tree t;`	`tree t;`

`if (type == NULL \|\| type == error_mark_node)`	`if (type == NULL \|\| type == error_mark_node)`
`return;`	`return;`

`type = TYPE_MAIN_VARIANT (type);`	`type = TYPE_MAIN_VARIANT (type);`

`if (TREE_CODE (type) == INTEGER_TYPE)`	`if (TREE_CODE (type) == INTEGER_TYPE)`
`{`	`{`
`gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);`	`gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);`
`gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);`	`gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);`

`for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))`	`for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))`
`{`	`{`
`TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);`	`TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);`
`TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);`	`TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);`
`}`	`}`
`}`	`}`
`else if (TREE_CODE (type) == ARRAY_TYPE)`	`else if (TREE_CODE (type) == ARRAY_TYPE)`
`{`	`{`
`gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);`	`gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);`
`gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);`	`gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);`
`gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);`	`gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);`
`gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);`	`gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);`

`for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))`	`for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))`
`{`	`{`
`TYPE_SIZE (t) = TYPE_SIZE (type);`	`TYPE_SIZE (t) = TYPE_SIZE (type);`
`TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);`	`TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);`
`}`	`}`
`}`	`}`
`}`	`}`

`/* Make sure all type sizes and array domains are either constant,`	`/* Make sure all type sizes and array domains are either constant,`
`or variable or parameter decls. This is a simplified variant`	`or variable or parameter decls. This is a simplified variant`
`of gimplify_type_sizes, but we can't use it here, as none of the`	`of gimplify_type_sizes, but we can't use it here, as none of the`
`variables in the expressions have been gimplified yet.`	`variables in the expressions have been gimplified yet.`
`As type sizes and domains for various variable length arrays`	`As type sizes and domains for various variable length arrays`
`contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars`	`contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars`
`time, without this routine gimplify_type_sizes in the middle-end`	`time, without this routine gimplify_type_sizes in the middle-end`
`could result in the type sizes being gimplified earlier than where`	`could result in the type sizes being gimplified earlier than where`
`those variables are initialized. */`	`those variables are initialized. */`

`void`	`void`
`gfc_trans_vla_type_sizes (gfc_symbol sym, stmtblock_t body)`	`gfc_trans_vla_type_sizes (gfc_symbol sym, stmtblock_t body)`
`{`	`{`
`tree type = TREE_TYPE (sym->backend_decl);`	`tree type = TREE_TYPE (sym->backend_decl);`

`if (TREE_CODE (type) == FUNCTION_TYPE`	`if (TREE_CODE (type) == FUNCTION_TYPE`
`&& (sym->attr.function \|\| sym->attr.result \|\| sym->attr.entry))`	`&& (sym->attr.function \|\| sym->attr.result \|\| sym->attr.entry))`
`{`	`{`
`if (! current_fake_result_decl)`	`if (! current_fake_result_decl)`
`return;`	`return;`

`type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));`	`type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));`
`}`	`}`

`while (POINTER_TYPE_P (type))`	`while (POINTER_TYPE_P (type))`
`type = TREE_TYPE (type);`	`type = TREE_TYPE (type);`

`if (GFC_DESCRIPTOR_TYPE_P (type))`	`if (GFC_DESCRIPTOR_TYPE_P (type))`
`{`	`{`
`tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);`	`tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);`

`while (POINTER_TYPE_P (etype))`	`while (POINTER_TYPE_P (etype))`
`etype = TREE_TYPE (etype);`	`etype = TREE_TYPE (etype);`

`gfc_trans_vla_type_sizes_1 (etype, body);`	`gfc_trans_vla_type_sizes_1 (etype, body);`
`}`	`}`

`gfc_trans_vla_type_sizes_1 (type, body);`	`gfc_trans_vla_type_sizes_1 (type, body);`
`}`	`}`


`/* Initialize a derived type by building an lvalue from the symbol`	`/* Initialize a derived type by building an lvalue from the symbol`
`and using trans_assignment to do the work. */`	`and using trans_assignment to do the work. */`
`tree`	`tree`
`gfc_init_default_dt (gfc_symbol * sym, tree body)`	`gfc_init_default_dt (gfc_symbol * sym, tree body)`
`{`	`{`
`stmtblock_t fnblock;`	`stmtblock_t fnblock;`
`gfc_expr *e;`	`gfc_expr *e;`
`tree tmp;`	`tree tmp;`
`tree present;`	`tree present;`

`gfc_init_block (&fnblock);`	`gfc_init_block (&fnblock);`
`gcc_assert (!sym->attr.allocatable);`	`gcc_assert (!sym->attr.allocatable);`
`gfc_set_sym_referenced (sym);`	`gfc_set_sym_referenced (sym);`
`e = gfc_lval_expr_from_sym (sym);`	`e = gfc_lval_expr_from_sym (sym);`
`tmp = gfc_trans_assignment (e, sym->value, false);`	`tmp = gfc_trans_assignment (e, sym->value, false);`
`if (sym->attr.dummy && (sym->attr.optional`	`if (sym->attr.dummy && (sym->attr.optional`
`\|\| sym->ns->proc_name->attr.entry_master))`	`\|\| sym->ns->proc_name->attr.entry_master))`
`{`	`{`
`present = gfc_conv_expr_present (sym);`	`present = gfc_conv_expr_present (sym);`
`tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,`	`tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,`
`tmp, build_empty_stmt (input_location));`	`tmp, build_empty_stmt (input_location));`
`}`	`}`
`gfc_add_expr_to_block (&fnblock, tmp);`	`gfc_add_expr_to_block (&fnblock, tmp);`
`gfc_free_expr (e);`	`gfc_free_expr (e);`
`if (body)`	`if (body)`
`gfc_add_expr_to_block (&fnblock, body);`	`gfc_add_expr_to_block (&fnblock, body);`
`return gfc_finish_block (&fnblock);`	`return gfc_finish_block (&fnblock);`
`}`	`}`


`/* Initialize INTENT(OUT) derived type dummies. As well as giving`	`/* Initialize INTENT(OUT) derived type dummies. As well as giving`
`them their default initializer, if they do not have allocatable`	`them their default initializer, if they do not have allocatable`
`components, they have their allocatable components deallocated. */`	`components, they have their allocatable components deallocated. */`

`static tree`	`static tree`
`init_intent_out_dt (gfc_symbol * proc_sym, tree body)`	`init_intent_out_dt (gfc_symbol * proc_sym, tree body)`
`{`	`{`
`stmtblock_t fnblock;`	`stmtblock_t fnblock;`
`gfc_formal_arglist *f;`	`gfc_formal_arglist *f;`
`tree tmp;`	`tree tmp;`
`tree present;`	`tree present;`

`gfc_init_block (&fnblock);`	`gfc_init_block (&fnblock);`
`for (f = proc_sym->formal; f; f = f->next)`	`for (f = proc_sym->formal; f; f = f->next)`
`if (f->sym && f->sym->attr.intent == INTENT_OUT`	`if (f->sym && f->sym->attr.intent == INTENT_OUT`
`&& !f->sym->attr.pointer`	`&& !f->sym->attr.pointer`
`&& f->sym->ts.type == BT_DERIVED)`	`&& f->sym->ts.type == BT_DERIVED)`
`{`	`{`
`if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)`	`if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)`
`{`	`{`
`tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,`	`tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,`
`f->sym->backend_decl,`	`f->sym->backend_decl,`
`f->sym->as ? f->sym->as->rank : 0);`	`f->sym->as ? f->sym->as->rank : 0);`

`if (f->sym->attr.optional`	`if (f->sym->attr.optional`
`\|\| f->sym->ns->proc_name->attr.entry_master)`	`\|\| f->sym->ns->proc_name->attr.entry_master)`
`{`	`{`
`present = gfc_conv_expr_present (f->sym);`	`present = gfc_conv_expr_present (f->sym);`
`tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,`	`tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,`
`tmp, build_empty_stmt (input_location));`	`tmp, build_empty_stmt (input_location));`
`}`	`}`

`gfc_add_expr_to_block (&fnblock, tmp);`	`gfc_add_expr_to_block (&fnblock, tmp);`
`}`	`}`
`else if (f->sym->value)`	`else if (f->sym->value)`
`body = gfc_init_default_dt (f->sym, body);`	`body = gfc_init_default_dt (f->sym, body);`
`}`	`}`

`gfc_add_expr_to_block (&fnblock, body);`	`gfc_add_expr_to_block (&fnblock, body);`
`return gfc_finish_block (&fnblock);`	`return gfc_finish_block (&fnblock);`
`}`	`}`


`/* Generate function entry and exit code, and add it to the function body.`	`/* Generate function entry and exit code, and add it to the function body.`
`This includes:`	`This includes:`
`Allocation and initialization of array variables.`	`Allocation and initialization of array variables.`
`Allocation of character string variables.`	`Allocation of character string variables.`
`Initialization and possibly repacking of dummy arrays.`	`Initialization and possibly repacking of dummy arrays.`
`Initialization of ASSIGN statement auxiliary variable.`	`Initialization of ASSIGN statement auxiliary variable.`
`Automatic deallocation. */`	`Automatic deallocation. */`

`tree`	`tree`
`gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)`	`gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)`
`{`	`{`
`locus loc;`	`locus loc;`
`gfc_symbol *sym;`	`gfc_symbol *sym;`
`gfc_formal_arglist *f;`	`gfc_formal_arglist *f;`
`stmtblock_t body;`	`stmtblock_t body;`
`bool seen_trans_deferred_array = false;`	`bool seen_trans_deferred_array = false;`

`/* Deal with implicit return variables. Explicit return variables will`	`/* Deal with implicit return variables. Explicit return variables will`
`already have been added. */`	`already have been added. */`
`if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)`	`if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)`
`{`	`{`
`if (!current_fake_result_decl)`	`if (!current_fake_result_decl)`
`{`	`{`
`gfc_entry_list *el = NULL;`	`gfc_entry_list *el = NULL;`
`if (proc_sym->attr.entry_master)`	`if (proc_sym->attr.entry_master)`
`{`	`{`
`for (el = proc_sym->ns->entries; el; el = el->next)`	`for (el = proc_sym->ns->entries; el; el = el->next)`
`if (el->sym != el->sym->result)`	`if (el->sym != el->sym->result)`
`break;`	`break;`
`}`	`}`
`/* TODO: move to the appropriate place in resolve.c. */`	`/* TODO: move to the appropriate place in resolve.c. */`
`if (warn_return_type && el == NULL)`	`if (warn_return_type && el == NULL)`
`gfc_warning ("Return value of function '%s' at %L not set",`	`gfc_warning ("Return value of function '%s' at %L not set",`
`proc_sym->name, &proc_sym->declared_at);`	`proc_sym->name, &proc_sym->declared_at);`
`}`	`}`
`else if (proc_sym->as)`	`else if (proc_sym->as)`
`{`	`{`
`tree result = TREE_VALUE (current_fake_result_decl);`	`tree result = TREE_VALUE (current_fake_result_decl);`
`fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);`	`fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);`

`/* An automatic character length, pointer array result. */`	`/* An automatic character length, pointer array result. */`
`if (proc_sym->ts.type == BT_CHARACTER`	`if (proc_sym->ts.type == BT_CHARACTER`
`&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)`	`&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)`
`fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,`	`fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,`
`fnbody);`	`fnbody);`
`}`	`}`
`else if (proc_sym->ts.type == BT_CHARACTER)`	`else if (proc_sym->ts.type == BT_CHARACTER)`
`{`	`{`
`if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)`	`if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)`
`fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,`	`fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,`
`fnbody);`	`fnbody);`
`}`	`}`
`else`	`else`
`gcc_assert (gfc_option.flag_f2c`	`gcc_assert (gfc_option.flag_f2c`
`&& proc_sym->ts.type == BT_COMPLEX);`	`&& proc_sym->ts.type == BT_COMPLEX);`
`}`	`}`

`/* Initialize the INTENT(OUT) derived type dummy arguments. This`	`/* Initialize the INTENT(OUT) derived type dummy arguments. This`
`should be done here so that the offsets and lbounds of arrays`	`should be done here so that the offsets and lbounds of arrays`
`are available. */`	`are available. */`
`fnbody = init_intent_out_dt (proc_sym, fnbody);`	`fnbody = init_intent_out_dt (proc_sym, fnbody);`

`for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)`	`for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)`
`{`	`{`
`bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)`	`bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)`
`&& sym->ts.u.derived->attr.alloc_comp;`	`&& sym->ts.u.derived->attr.alloc_comp;`
`if (sym->attr.dimension)`	`if (sym->attr.dimension)`
`{`	`{`
`switch (sym->as->type)`	`switch (sym->as->type)`
`{`	`{`
`case AS_EXPLICIT:`	`case AS_EXPLICIT:`
`if (sym->attr.dummy \|\| sym->attr.result)`	`if (sym->attr.dummy \|\| sym->attr.result)`
`fnbody =`	`fnbody =`
`gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);`	`gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);`
`else if (sym->attr.pointer \|\| sym->attr.allocatable)`	`else if (sym->attr.pointer \|\| sym->attr.allocatable)`
`{`	`{`
`if (TREE_STATIC (sym->backend_decl))`	`if (TREE_STATIC (sym->backend_decl))`
`gfc_trans_static_array_pointer (sym);`	`gfc_trans_static_array_pointer (sym);`
`else`	`else`
`{`	`{`
`seen_trans_deferred_array = true;`	`seen_trans_deferred_array = true;`
`fnbody = gfc_trans_deferred_array (sym, fnbody);`	`fnbody = gfc_trans_deferred_array (sym, fnbody);`
`}`	`}`
`}`	`}`
`else`	`else`
`{`	`{`
`if (sym_has_alloc_comp)`	`if (sym_has_alloc_comp)`
`{`	`{`
`seen_trans_deferred_array = true;`	`seen_trans_deferred_array = true;`
`fnbody = gfc_trans_deferred_array (sym, fnbody);`	`fnbody = gfc_trans_deferred_array (sym, fnbody);`
`}`	`}`
`else if (sym->ts.type == BT_DERIVED`	`else if (sym->ts.type == BT_DERIVED`
`&& sym->value`	`&& sym->value`
`&& !sym->attr.data`	`&& !sym->attr.data`
`&& sym->attr.save == SAVE_NONE)`	`&& sym->attr.save == SAVE_NONE)`
`fnbody = gfc_init_default_dt (sym, fnbody);`	`fnbody = gfc_init_default_dt (sym, fnbody);`

`gfc_get_backend_locus (&loc);`	`gfc_get_backend_locus (&loc);`
`gfc_set_backend_locus (&sym->declared_at);`	`gfc_set_backend_locus (&sym->declared_at);`
`fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,`	`fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,`
`sym, fnbody);`	`sym, fnbody);`
`gfc_set_backend_locus (&loc);`	`gfc_set_backend_locus (&loc);`
`}`	`}`
`break;`	`break;`

`case AS_ASSUMED_SIZE:`	`case AS_ASSUMED_SIZE:`
`/* Must be a dummy parameter. */`	`/* Must be a dummy parameter. */`
`gcc_assert (sym->attr.dummy \|\| sym->as->cp_was_assumed);`	`gcc_assert (sym->attr.dummy \|\| sym->as->cp_was_assumed);`

`/* We should always pass assumed size arrays the g77 way. */`	`/* We should always pass assumed size arrays the g77 way. */`
`if (sym->attr.dummy)`	`if (sym->attr.dummy)`
`fnbody = gfc_trans_g77_array (sym, fnbody);`	`fnbody = gfc_trans_g77_array (sym, fnbody);`
`break;`	`break;`

`case AS_ASSUMED_SHAPE:`	`case AS_ASSUMED_SHAPE:`
`/* Must be a dummy parameter. */`	`/* Must be a dummy parameter. */`
`gcc_assert (sym->attr.dummy);`	`gcc_assert (sym->attr.dummy);`

`fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,`	`fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,`
`fnbody);`	`fnbody);`
`break;`	`break;`

`case AS_DEFERRED:`	`case AS_DEFERRED:`
`seen_trans_deferred_array = true;`	`seen_trans_deferred_array = true;`
`fnbody = gfc_trans_deferred_array (sym, fnbody);`	`fnbody = gfc_trans_deferred_array (sym, fnbody);`
`break;`	`break;`

`default:`	`default:`
`gcc_unreachable ();`	`gcc_unreachable ();`
`}`	`}`
`if (sym_has_alloc_comp && !seen_trans_deferred_array)`	`if (sym_has_alloc_comp && !seen_trans_deferred_array)`
`fnbody = gfc_trans_deferred_array (sym, fnbody);`	`fnbody = gfc_trans_deferred_array (sym, fnbody);`
`}`	`}`
`else if (sym_has_alloc_comp)`	`else if (sym_has_alloc_comp)`
`fnbody = gfc_trans_deferred_array (sym, fnbody);`	`fnbody = gfc_trans_deferred_array (sym, fnbody);`
`else if (sym->attr.allocatable`	`else if (sym->attr.allocatable`
`\|\| (sym->ts.type == BT_CLASS`	`\|\| (sym->ts.type == BT_CLASS`
`&& sym->ts.u.derived->components->attr.allocatable))`	`&& sym->ts.u.derived->components->attr.allocatable))`
`{`	`{`
`if (!sym->attr.save)`	`if (!sym->attr.save)`
`{`	`{`
`/* Nullify and automatic deallocation of allocatable`	`/* Nullify and automatic deallocation of allocatable`
`scalars. */`	`scalars. */`
`tree tmp;`	`tree tmp;`
`gfc_expr *e;`	`gfc_expr *e;`
`gfc_se se;`	`gfc_se se;`
`stmtblock_t block;`	`stmtblock_t block;`

`e = gfc_lval_expr_from_sym (sym);`	`e = gfc_lval_expr_from_sym (sym);`
`if (sym->ts.type == BT_CLASS)`	`if (sym->ts.type == BT_CLASS)`
`gfc_add_component_ref (e, "$data");`	`gfc_add_component_ref (e, "$data");`

`gfc_init_se (&se, NULL);`	`gfc_init_se (&se, NULL);`
`se.want_pointer = 1;`	`se.want_pointer = 1;`
`gfc_conv_expr (&se, e);`	`gfc_conv_expr (&se, e);`
`gfc_free_expr (e);`	`gfc_free_expr (e);`

`/* Nullify when entering the scope. */`	`/* Nullify when entering the scope. */`
`gfc_start_block (&block);`	`gfc_start_block (&block);`
`gfc_add_modify (&block, se.expr,`	`gfc_add_modify (&block, se.expr,`
`fold_convert (TREE_TYPE (se.expr),`	`fold_convert (TREE_TYPE (se.expr),`
`null_pointer_node));`	`null_pointer_node));`
`gfc_add_expr_to_block (&block, fnbody);`	`gfc_add_expr_to_block (&block, fnbody);`

`/* Deallocate when leaving the scope. Nullifying is not`	`/* Deallocate when leaving the scope. Nullifying is not`
`needed. */`	`needed. */`
`tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,`	`tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,`
`NULL);`	`NULL);`
`gfc_add_expr_to_block (&block, tmp);`	`gfc_add_expr_to_block (&block, tmp);`
`fnbody = gfc_finish_block (&block);`	`fnbody = gfc_finish_block (&block);`
`}`	`}`
`}`	`}`
`else if (sym->ts.type == BT_CHARACTER)`	`else if (sym->ts.type == BT_CHARACTER)`
`{`	`{`
`gfc_get_backend_locus (&loc);`	`gfc_get_backend_locus (&loc);`
`gfc_set_backend_locus (&sym->declared_at);`	`gfc_set_backend_locus (&sym->declared_at);`
`if (sym->attr.dummy \|\| sym->attr.result)`	`if (sym->attr.dummy \|\| sym->attr.result)`
`fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);`	`fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);`
`else`	`else`
`fnbody = gfc_trans_auto_character_variable (sym, fnbody);`	`fnbody = gfc_trans_auto_character_variable (sym, fnbody);`
`gfc_set_backend_locus (&loc);`	`gfc_set_backend_locus (&loc);`
`}`	`}`
`else if (sym->attr.assign)`	`else if (sym->attr.assign)`
`{`	`{`
`gfc_get_backend_locus (&loc);`	`gfc_get_backend_locus (&loc);`
`gfc_set_backend_locus (&sym->declared_at);`	`gfc_set_backend_locus (&sym->declared_at);`
`fnbody = gfc_trans_assign_aux_var (sym, fnbody);`	`fnbody = gfc_trans_assign_aux_var (sym, fnbody);`
`gfc_set_backend_locus (&loc);`	`gfc_set_backend_locus (&loc);`
`}`	`}`
`else if (sym->ts.type == BT_DERIVED`	`else if (sym->ts.type == BT_DERIVED`
`&& sym->value`	`&& sym->value`
`&& !sym->attr.data`	`&& !sym->attr.data`
`&& sym->attr.save == SAVE_NONE)`	`&& sym->attr.save == SAVE_NONE)`
`fnbody = gfc_init_default_dt (sym, fnbody);`	`fnbody = gfc_init_default_dt (sym, fnbody);`
`else`	`else`
`gcc_unreachable ();`	`gcc_unreachable ();`
`}`	`}`

`gfc_init_block (&body);`	`gfc_init_block (&body);`

`for (f = proc_sym->formal; f; f = f->next)`	`for (f = proc_sym->formal; f; f = f->next)`
`{`	`{`
`if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)`	`if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)`
`{`	`{`
`gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);`	`gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);`
`if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)`	`if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)`
`gfc_trans_vla_type_sizes (f->sym, &body);`	`gfc_trans_vla_type_sizes (f->sym, &body);`
`}`	`}`
`}`	`}`

`if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER`	`if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER`
`&& current_fake_result_decl != NULL)`	`&& current_fake_result_decl != NULL)`
`{`	`{`
`gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);`	`gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);`
`if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)`	`if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)`
`gfc_trans_vla_type_sizes (proc_sym, &body);`	`gfc_trans_vla_type_sizes (proc_sym, &body);`
`}`	`}`

`gfc_add_expr_to_block (&body, fnbody);`	`gfc_add_expr_to_block (&body, fnbody);`
`return gfc_finish_block (&body);`	`return gfc_finish_block (&body);`
`}`	`}`

`static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;`	`static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;`

`/* Hash and equality functions for module_htab. */`	`/* Hash and equality functions for module_htab. */`

`static hashval_t`	`static hashval_t`
`module_htab_do_hash (const void *x)`	`module_htab_do_hash (const void *x)`
`{`	`{`
`return htab_hash_string (((const struct module_htab_entry *)x)->name);`	`return htab_hash_string (((const struct module_htab_entry *)x)->name);`
`}`	`}`

`static int`	`static int`
`module_htab_eq (const void x1, const void x2)`	`module_htab_eq (const void x1, const void x2)`
`{`	`{`
`return strcmp ((((const struct module_htab_entry *)x1)->name),`	`return strcmp ((((const struct module_htab_entry *)x1)->name),`
`(const char *)x2) == 0;`	`(const char *)x2) == 0;`
`}`	`}`

`/* Hash and equality functions for module_htab's decls. */`	`/* Hash and equality functions for module_htab's decls. */`

`static hashval_t`	`static hashval_t`
`module_htab_decls_hash (const void *x)`	`module_htab_decls_hash (const void *x)`
`{`	`{`
`const_tree t = (const_tree) x;`	`const_tree t = (const_tree) x;`
`const_tree n = DECL_NAME (t);`	`const_tree n = DECL_NAME (t);`
`if (n == NULL_TREE)`	`if (n == NULL_TREE)`
`n = TYPE_NAME (TREE_TYPE (t));`	`n = TYPE_NAME (TREE_TYPE (t));`
`return htab_hash_string (IDENTIFIER_POINTER (n));`	`return htab_hash_string (IDENTIFIER_POINTER (n));`
`}`	`}`

`static int`	`static int`
`module_htab_decls_eq (const void x1, const void x2)`	`module_htab_decls_eq (const void x1, const void x2)`
`{`	`{`
`const_tree t1 = (const_tree) x1;`	`const_tree t1 = (const_tree) x1;`
`const_tree n1 = DECL_NAME (t1);`	`const_tree n1 = DECL_NAME (t1);`
`if (n1 == NULL_TREE)`	`if (n1 == NULL_TREE)`
`n1 = TYPE_NAME (TREE_TYPE (t1));`	`n1 = TYPE_NAME (TREE_TYPE (t1));`
`return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;`	`return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;`
`}`	`}`

`struct module_htab_entry *`	`struct module_htab_entry *`
`gfc_find_module (const char *name)`	`gfc_find_module (const char *name)`
`{`	`{`
`void **slot;`	`void **slot;`

`if (! module_htab)`	`if (! module_htab)`
`module_htab = htab_create_ggc (10, module_htab_do_hash,`	`module_htab = htab_create_ggc (10, module_htab_do_hash,`
`module_htab_eq, NULL);`	`module_htab_eq, NULL);`

`slot = htab_find_slot_with_hash (module_htab, name,`	`slot = htab_find_slot_with_hash (module_htab, name,`
`htab_hash_string (name), INSERT);`	`htab_hash_string (name), INSERT);`
`if (*slot == NULL)`	`if (*slot == NULL)`
`{`	`{`
`struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);`	`struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);`

`entry->name = gfc_get_string (name);`	`entry->name = gfc_get_string (name);`
`entry->decls = htab_create_ggc (10, module_htab_decls_hash,`	`entry->decls = htab_create_ggc (10, module_htab_decls_hash,`
`module_htab_decls_eq, NULL);`	`module_htab_decls_eq, NULL);`
`slot = (void ) entry;`	`slot = (void ) entry;`
`}`	`}`
`return (struct module_htab_entry ) slot;`	`return (struct module_htab_entry ) slot;`
`}`	`}`

`void`	`void`
`gfc_module_add_decl (struct module_htab_entry *entry, tree decl)`	`gfc_module_add_decl (struct module_htab_entry *entry, tree decl)`
`{`	`{`
`void **slot;`	`void **slot;`
`const char *name;`	`const char *name;`

`if (DECL_NAME (decl))`	`if (DECL_NAME (decl))`
`name = IDENTIFIER_POINTER (DECL_NAME (decl));`	`name = IDENTIFIER_POINTER (DECL_NAME (decl));`
`else`	`else`
`{`	`{`
`gcc_assert (TREE_CODE (decl) == TYPE_DECL);`	`gcc_assert (TREE_CODE (decl) == TYPE_DECL);`
`name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));`	`name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));`
`}`	`}`
`slot = htab_find_slot_with_hash (entry->decls, name,`	`slot = htab_find_slot_with_hash (entry->decls, name,`
`htab_hash_string (name), INSERT);`	`htab_hash_string (name), INSERT);`
`if (*slot == NULL)`	`if (*slot == NULL)`
`slot = (void ) decl;`	`slot = (void ) decl;`
`}`	`}`

`static struct module_htab_entry *cur_module;`	`static struct module_htab_entry *cur_module;`

`/* Output an initialized decl for a module variable. */`	`/* Output an initialized decl for a module variable. */`

`static void`	`static void`
`gfc_create_module_variable (gfc_symbol * sym)`	`gfc_create_module_variable (gfc_symbol * sym)`
`{`	`{`
`tree decl;`	`tree decl;`

`/* Module functions with alternate entries are dealt with later and`	`/* Module functions with alternate entries are dealt with later and`
`would get caught by the next condition. */`	`would get caught by the next condition. */`
`if (sym->attr.entry)`	`if (sym->attr.entry)`
`return;`	`return;`

`/* Make sure we convert the types of the derived types from iso_c_binding`	`/* Make sure we convert the types of the derived types from iso_c_binding`
`into (void ). /`	`into (void ). /`
`if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c`	`if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c`
`&& sym->ts.type == BT_DERIVED)`	`&& sym->ts.type == BT_DERIVED)`
`sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));`	`sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));`

`if (sym->attr.flavor == FL_DERIVED`	`if (sym->attr.flavor == FL_DERIVED`
`&& sym->backend_decl`	`&& sym->backend_decl`
`&& TREE_CODE (sym->backend_decl) == RECORD_TYPE)`	`&& TREE_CODE (sym->backend_decl) == RECORD_TYPE)`
`{`	`{`
`decl = sym->backend_decl;`	`decl = sym->backend_decl;`
`gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);`	`gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);`

`/* -fwhole-file mixes up the contexts so these asserts are unnecessary. */`	`/* -fwhole-file mixes up the contexts so these asserts are unnecessary. */`
`if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))`	`if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))`
`{`	`{`
`gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE`	`gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE`
`\|\| TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);`	`\|\| TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);`
`gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE`	`gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE`
`\|\| DECL_CONTEXT (TYPE_STUB_DECL (decl))`	`\|\| DECL_CONTEXT (TYPE_STUB_DECL (decl))`
`== sym->ns->proc_name->backend_decl);`	`== sym->ns->proc_name->backend_decl);`
`}`	`}`
`TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;`	`TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;`
`DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;`	`DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;`
`gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));`	`gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));`
`}`	`}`

`/* Only output variables, procedure pointers and array valued,`	`/* Only output variables, procedure pointers and array valued,`
`or derived type, parameters. */`	`or derived type, parameters. */`
`if (sym->attr.flavor != FL_VARIABLE`	`if (sym->attr.flavor != FL_VARIABLE`
`&& !(sym->attr.flavor == FL_PARAMETER`	`&& !(sym->attr.flavor == FL_PARAMETER`
`&& (sym->attr.dimension \|\| sym->ts.type == BT_DERIVED))`	`&& (sym->attr.dimension \|\| sym->ts.type == BT_DERIVED))`
`&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))`	`&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))`
`return;`	`return;`

`if ((sym->attr.in_common \|\| sym->attr.in_equivalence) && sym->backend_decl)`	`if ((sym->attr.in_common \|\| sym->attr.in_equivalence) && sym->backend_decl)`
`{`	`{`
`decl = sym->backend_decl;`	`decl = sym->backend_decl;`
`gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);`	`gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);`
`gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);`	`gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);`
`DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;`	`DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;`
`gfc_module_add_decl (cur_module, decl);`	`gfc_module_add_decl (cur_module, decl);`
`}`	`}`

`/* Don't generate variables from other modules. Variables from`	`/* Don't generate variables from other modules. Variables from`
`COMMONs will already have been generated. */`	`COMMONs will already have been generated. */`
`if (sym->attr.use_assoc \|\| sym->attr.in_common)`	`if (sym->attr.use_assoc \|\| sym->attr.in_common)`
`return;`	`return;`

`/* Equivalenced variables arrive here after creation. */`	`/* Equivalenced variables arrive here after creation. */`
`if (sym->backend_decl`	`if (sym->backend_decl`
`&& (sym->equiv_built \|\| sym->attr.in_equivalence))`	`&& (sym->equiv_built \|\| sym->attr.in_equivalence))`
`return;`	`return;`

`if (sym->backend_decl && !sym->attr.vtab)`	`if (sym->backend_decl && !sym->attr.vtab)`
`internal_error ("backend decl for module variable %s already exists",`	`internal_error ("backend decl for module variable %s already exists",`
`sym->name);`	`sym->name);`

`/* We always want module variables to be created. */`	`/* We always want module variables to be created. */`
`sym->attr.referenced = 1;`	`sym->attr.referenced = 1;`
`/* Create the decl. */`	`/* Create the decl. */`
`decl = gfc_get_symbol_decl (sym);`	`decl = gfc_get_symbol_decl (sym);`

`/* Create the variable. */`	`/* Create the variable. */`
`pushdecl (decl);`	`pushdecl (decl);`
`gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);`	`gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);`
`gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);`	`gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);`
`DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;`	`DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;`
`rest_of_decl_compilation (decl, 1, 0);`	`rest_of_decl_compilation (decl, 1, 0);`
`gfc_module_add_decl (cur_module, decl);`	`gfc_module_add_decl (cur_module, decl);`

`/* Also add length of strings. */`	`/* Also add length of strings. */`
`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`{`	`{`
`tree length;`	`tree length;`

`length = sym->ts.u.cl->backend_decl;`	`length = sym->ts.u.cl->backend_decl;`
`gcc_assert (length \|\| sym->attr.proc_pointer);`	`gcc_assert (length \|\| sym->attr.proc_pointer);`
`if (length && !INTEGER_CST_P (length))`	`if (length && !INTEGER_CST_P (length))`
`{`	`{`
`pushdecl (length);`	`pushdecl (length);`
`rest_of_decl_compilation (length, 1, 0);`	`rest_of_decl_compilation (length, 1, 0);`
`}`	`}`
`}`	`}`
`}`	`}`

`/* Emit debug information for USE statements. */`	`/* Emit debug information for USE statements. */`

`static void`	`static void`
`gfc_trans_use_stmts (gfc_namespace * ns)`	`gfc_trans_use_stmts (gfc_namespace * ns)`
`{`	`{`
`gfc_use_list *use_stmt;`	`gfc_use_list *use_stmt;`
`for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)`	`for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)`
`{`	`{`
`struct module_htab_entry *entry`	`struct module_htab_entry *entry`
`= gfc_find_module (use_stmt->module_name);`	`= gfc_find_module (use_stmt->module_name);`
`gfc_use_rename *rent;`	`gfc_use_rename *rent;`

`if (entry->namespace_decl == NULL)`	`if (entry->namespace_decl == NULL)`
`{`	`{`
`entry->namespace_decl`	`entry->namespace_decl`
`= build_decl (input_location,`	`= build_decl (input_location,`
`NAMESPACE_DECL,`	`NAMESPACE_DECL,`
`get_identifier (use_stmt->module_name),`	`get_identifier (use_stmt->module_name),`
`void_type_node);`	`void_type_node);`
`DECL_EXTERNAL (entry->namespace_decl) = 1;`	`DECL_EXTERNAL (entry->namespace_decl) = 1;`
`}`	`}`
`gfc_set_backend_locus (&use_stmt->where);`	`gfc_set_backend_locus (&use_stmt->where);`
`if (!use_stmt->only_flag)`	`if (!use_stmt->only_flag)`
`(*debug_hooks->imported_module_or_decl) (entry->namespace_decl,`	`(*debug_hooks->imported_module_or_decl) (entry->namespace_decl,`
`NULL_TREE,`	`NULL_TREE,`
`ns->proc_name->backend_decl,`	`ns->proc_name->backend_decl,`
`false);`	`false);`
`for (rent = use_stmt->rename; rent; rent = rent->next)`	`for (rent = use_stmt->rename; rent; rent = rent->next)`
`{`	`{`
`tree decl, local_name;`	`tree decl, local_name;`
`void **slot;`	`void **slot;`

`if (rent->op != INTRINSIC_NONE)`	`if (rent->op != INTRINSIC_NONE)`
`continue;`	`continue;`

`slot = htab_find_slot_with_hash (entry->decls, rent->use_name,`	`slot = htab_find_slot_with_hash (entry->decls, rent->use_name,`
`htab_hash_string (rent->use_name),`	`htab_hash_string (rent->use_name),`
`INSERT);`	`INSERT);`
`if (*slot == NULL)`	`if (*slot == NULL)`
`{`	`{`
`gfc_symtree *st;`	`gfc_symtree *st;`

`st = gfc_find_symtree (ns->sym_root,`	`st = gfc_find_symtree (ns->sym_root,`
`rent->local_name[0]`	`rent->local_name[0]`
`? rent->local_name : rent->use_name);`	`? rent->local_name : rent->use_name);`
`gcc_assert (st);`	`gcc_assert (st);`

`/* Sometimes, generic interfaces wind up being over-ruled by a`	`/* Sometimes, generic interfaces wind up being over-ruled by a`
`local symbol (see PR41062). */`	`local symbol (see PR41062). */`
`if (!st->n.sym->attr.use_assoc)`	`if (!st->n.sym->attr.use_assoc)`
`continue;`	`continue;`

`if (st->n.sym->backend_decl`	`if (st->n.sym->backend_decl`
`&& DECL_P (st->n.sym->backend_decl)`	`&& DECL_P (st->n.sym->backend_decl)`
`&& st->n.sym->module`	`&& st->n.sym->module`
`&& strcmp (st->n.sym->module, use_stmt->module_name) == 0)`	`&& strcmp (st->n.sym->module, use_stmt->module_name) == 0)`
`{`	`{`
`gcc_assert (DECL_EXTERNAL (entry->namespace_decl)`	`gcc_assert (DECL_EXTERNAL (entry->namespace_decl)`
`\|\| (TREE_CODE (st->n.sym->backend_decl)`	`\|\| (TREE_CODE (st->n.sym->backend_decl)`
`!= VAR_DECL));`	`!= VAR_DECL));`
`decl = copy_node (st->n.sym->backend_decl);`	`decl = copy_node (st->n.sym->backend_decl);`
`DECL_CONTEXT (decl) = entry->namespace_decl;`	`DECL_CONTEXT (decl) = entry->namespace_decl;`
`DECL_EXTERNAL (decl) = 1;`	`DECL_EXTERNAL (decl) = 1;`
`DECL_IGNORED_P (decl) = 0;`	`DECL_IGNORED_P (decl) = 0;`
`DECL_INITIAL (decl) = NULL_TREE;`	`DECL_INITIAL (decl) = NULL_TREE;`
`}`	`}`
`else`	`else`
`{`	`{`
`*slot = error_mark_node;`	`*slot = error_mark_node;`
`htab_clear_slot (entry->decls, slot);`	`htab_clear_slot (entry->decls, slot);`
`continue;`	`continue;`
`}`	`}`
`*slot = decl;`	`*slot = decl;`
`}`	`}`
`decl = (tree) *slot;`	`decl = (tree) *slot;`
`if (rent->local_name[0])`	`if (rent->local_name[0])`
`local_name = get_identifier (rent->local_name);`	`local_name = get_identifier (rent->local_name);`
`else`	`else`
`local_name = NULL_TREE;`	`local_name = NULL_TREE;`
`gfc_set_backend_locus (&rent->where);`	`gfc_set_backend_locus (&rent->where);`
`(*debug_hooks->imported_module_or_decl) (decl, local_name,`	`(*debug_hooks->imported_module_or_decl) (decl, local_name,`
`ns->proc_name->backend_decl,`	`ns->proc_name->backend_decl,`
`!use_stmt->only_flag);`	`!use_stmt->only_flag);`
`}`	`}`
`}`	`}`
`}`	`}`


`/* Return true if expr is a constant initializer that gfc_conv_initializer`	`/* Return true if expr is a constant initializer that gfc_conv_initializer`
`will handle. */`	`will handle. */`

`static bool`	`static bool`
`check_constant_initializer (gfc_expr expr, gfc_typespec ts, bool array,`	`check_constant_initializer (gfc_expr expr, gfc_typespec ts, bool array,`
`bool pointer)`	`bool pointer)`
`{`	`{`
`gfc_constructor *c;`	`gfc_constructor *c;`
`gfc_component *cm;`	`gfc_component *cm;`

`if (pointer)`	`if (pointer)`
`return true;`	`return true;`
`else if (array)`	`else if (array)`
`{`	`{`
`if (expr->expr_type == EXPR_CONSTANT \|\| expr->expr_type == EXPR_NULL)`	`if (expr->expr_type == EXPR_CONSTANT \|\| expr->expr_type == EXPR_NULL)`
`return true;`	`return true;`
`else if (expr->expr_type == EXPR_STRUCTURE)`	`else if (expr->expr_type == EXPR_STRUCTURE)`
`return check_constant_initializer (expr, ts, false, false);`	`return check_constant_initializer (expr, ts, false, false);`
`else if (expr->expr_type != EXPR_ARRAY)`	`else if (expr->expr_type != EXPR_ARRAY)`
`return false;`	`return false;`
`for (c = expr->value.constructor; c; c = c->next)`	`for (c = expr->value.constructor; c; c = c->next)`
`{`	`{`
`if (c->iterator)`	`if (c->iterator)`
`return false;`	`return false;`
`if (c->expr->expr_type == EXPR_STRUCTURE)`	`if (c->expr->expr_type == EXPR_STRUCTURE)`
`{`	`{`
`if (!check_constant_initializer (c->expr, ts, false, false))`	`if (!check_constant_initializer (c->expr, ts, false, false))`
`return false;`	`return false;`
`}`	`}`
`else if (c->expr->expr_type != EXPR_CONSTANT)`	`else if (c->expr->expr_type != EXPR_CONSTANT)`
`return false;`	`return false;`
`}`	`}`
`return true;`	`return true;`
`}`	`}`
`else switch (ts->type)`	`else switch (ts->type)`
`{`	`{`
`case BT_DERIVED:`	`case BT_DERIVED:`
`if (expr->expr_type != EXPR_STRUCTURE)`	`if (expr->expr_type != EXPR_STRUCTURE)`
`return false;`	`return false;`
`cm = expr->ts.u.derived->components;`	`cm = expr->ts.u.derived->components;`
`for (c = expr->value.constructor; c; c = c->next, cm = cm->next)`	`for (c = expr->value.constructor; c; c = c->next, cm = cm->next)`
`{`	`{`
`if (!c->expr \|\| cm->attr.allocatable)`	`if (!c->expr \|\| cm->attr.allocatable)`
`continue;`	`continue;`
`if (!check_constant_initializer (c->expr, &cm->ts,`	`if (!check_constant_initializer (c->expr, &cm->ts,`
`cm->attr.dimension,`	`cm->attr.dimension,`
`cm->attr.pointer))`	`cm->attr.pointer))`
`return false;`	`return false;`
`}`	`}`
`return true;`	`return true;`
`default:`	`default:`
`return expr->expr_type == EXPR_CONSTANT;`	`return expr->expr_type == EXPR_CONSTANT;`
`}`	`}`
`}`	`}`

`/* Emit debug info for parameters and unreferenced variables with`	`/* Emit debug info for parameters and unreferenced variables with`
`initializers. */`	`initializers. */`

`static void`	`static void`
`gfc_emit_parameter_debug_info (gfc_symbol *sym)`	`gfc_emit_parameter_debug_info (gfc_symbol *sym)`
`{`	`{`
`tree decl;`	`tree decl;`

`if (sym->attr.flavor != FL_PARAMETER`	`if (sym->attr.flavor != FL_PARAMETER`
`&& (sym->attr.flavor != FL_VARIABLE \|\| sym->attr.referenced))`	`&& (sym->attr.flavor != FL_VARIABLE \|\| sym->attr.referenced))`
`return;`	`return;`

`if (sym->backend_decl != NULL`	`if (sym->backend_decl != NULL`
`\|\| sym->value == NULL`	`\|\| sym->value == NULL`
`\|\| sym->attr.use_assoc`	`\|\| sym->attr.use_assoc`
`\|\| sym->attr.dummy`	`\|\| sym->attr.dummy`
`\|\| sym->attr.result`	`\|\| sym->attr.result`
`\|\| sym->attr.function`	`\|\| sym->attr.function`
`\|\| sym->attr.intrinsic`	`\|\| sym->attr.intrinsic`
`\|\| sym->attr.pointer`	`\|\| sym->attr.pointer`
`\|\| sym->attr.allocatable`	`\|\| sym->attr.allocatable`
`\|\| sym->attr.cray_pointee`	`\|\| sym->attr.cray_pointee`
`\|\| sym->attr.threadprivate`	`\|\| sym->attr.threadprivate`
`\|\| sym->attr.is_bind_c`	`\|\| sym->attr.is_bind_c`
`\|\| sym->attr.subref_array_pointer`	`\|\| sym->attr.subref_array_pointer`
`\|\| sym->attr.assign)`	`\|\| sym->attr.assign)`
`return;`	`return;`

`if (sym->ts.type == BT_CHARACTER)`	`if (sym->ts.type == BT_CHARACTER)`
`{`	`{`
`gfc_conv_const_charlen (sym->ts.u.cl);`	`gfc_conv_const_charlen (sym->ts.u.cl);`
`if (sym->ts.u.cl->backend_decl == NULL`	`if (sym->ts.u.cl->backend_decl == NULL`
`\|\| TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)`	`\|\| TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)`
`return;`	`return;`
`}`	`}`
`else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)`	`else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)`
`return;`	`return;`

`if (sym->as)`	`if (sym->as)`
`{`	`{`
`int n;`	`int n;`

`if (sym->as->type != AS_EXPLICIT)`	`if (sym->as->type != AS_EXPLICIT)`
`return;`	`return;`
`for (n = 0; n < sym->as->rank; n++)`	`for (n = 0; n < sym->as->rank; n++)`
`if (sym->as->lower[n]->expr_type != EXPR_CONSTANT`	`if (sym->as->lower[n]->expr_type != EXPR_CONSTANT`
`\|\| sym->as->upper[n] == NULL`	`\|\| sym->as->upper[n] == NULL`
`\|\| sym->as->upper[n]->expr_type != EXPR_CONSTANT)`	`\|\| sym->as->upper[n]->expr_type != EXPR_CONSTANT)`
`return;`	`return;`
`}`	`}`

`if (!check_constant_initializer (sym->value, &sym->ts,`	`if (!check_constant_initializer (sym->value, &sym->ts,`
`sym->attr.dimension, false))`	`sym->attr.dimension, false))`
`return;`	`return;`

`/* Create the decl for the variable or constant. */`	`/* Create the decl for the variable or constant. */`
`decl = build_decl (input_location,`	`decl = build_decl (input_location,`
`sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,`	`sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,`
`gfc_sym_identifier (sym), gfc_sym_type (sym));`	`gfc_sym_identifier (sym), gfc_sym_type (sym));`
`if (sym->attr.flavor == FL_PARAMETER)`	`if (sym->attr.flavor == FL_PARAMETER)`
`TREE_READONLY (decl) = 1;`	`TREE_READONLY (decl) = 1;`
`gfc_set_decl_location (decl, &sym->declared_at);`	`gfc_set_decl_location (decl, &sym->declared_at);`
`if (sym->attr.dimension)`	`if (sym->attr.dimension)`
`GFC_DECL_PACKED_ARRAY (decl) = 1;`	`GFC_DECL_PACKED_ARRAY (decl) = 1;`
`DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;`	`DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;`
`TREE_STATIC (decl) = 1;`	`TREE_STATIC (decl) = 1;`
`TREE_USED (decl) = 1;`	`TREE_USED (decl) = 1;`
`if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)`	`if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)`
`TREE_PUBLIC (decl) = 1;`	`TREE_PUBLIC (decl) = 1;`
`DECL_INITIAL (decl)`	`DECL_INITIAL (decl)`
`= gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),`	`= gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),`
`sym->attr.dimension, 0);`	`sym->attr.dimension, 0);`
`debug_hooks->global_decl (decl);`	`debug_hooks->global_decl (decl);`
`}`	`}`

`/* Generate all the required code for module variables. */`	`/* Generate all the required code for module variables. */`

`void`	`void`
`gfc_generate_module_vars (gfc_namespace * ns)`	`gfc_generate_module_vars (gfc_namespace * ns)`
`{`	`{`
`module_namespace = ns;`	`module_namespace = ns;`
`cur_module = gfc_find_module (ns->proc_name->name);`	`cur_module = gfc_find_module (ns->proc_name->name);`

`/* Check if the frontend left the namespace in a reasonable state. */`	`/* Check if the frontend left the namespace in a reasonable state. */`
`gcc_assert (ns->proc_name && !ns->proc_name->tlink);`	`gcc_assert (ns->proc_name && !ns->proc_name->tlink);`

`/* Generate COMMON blocks. */`	`/* Generate COMMON blocks. */`
`gfc_trans_common (ns);`	`gfc_trans_common (ns);`

`/* Create decls for all the module variables. */`	`/* Create decls for all the module variables. */`
`gfc_traverse_ns (ns, gfc_create_module_variable);`	`gfc_traverse_ns (ns, gfc_create_module_variable);`

`cur_module = NULL;`	`cur_module = NULL;`

`gfc_trans_use_stmts (ns);`	`gfc_trans_use_stmts (ns);`
`gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);`	`gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);`
`}`	`}`


`static void`	`static void`
`gfc_generate_contained_functions (gfc_namespace * parent)`	`gfc_generate_contained_functions (gfc_namespace * parent)`
`{`	`{`
`gfc_namespace *ns;`	`gfc_namespace *ns;`

`/* We create all the prototypes before generating any code. */`	`/* We create all the prototypes before generating any code. */`
`for (ns = parent->contained; ns; ns = ns->sibling)`	`for (ns = parent->contained; ns; ns = ns->sibling)`
`{`	`{`
`/* Skip namespaces from used modules. */`	`/* Skip namespaces from used modules. */`
`if (ns->parent != parent)`	`if (ns->parent != parent)`
`continue;`	`continue;`

`gfc_create_function_decl (ns);`	`gfc_create_function_decl (ns);`
`}`	`}`

`for (ns = parent->contained; ns; ns = ns->sibling)`	`for (ns = parent->contained; ns; ns = ns->sibling)`
`{`	`{`
`/* Skip namespaces from used modules. */`	`/* Skip namespaces from used modules. */`
`if (ns->parent != parent)`	`if (ns->parent != parent)`
`continue;`	`continue;`

`gfc_generate_function_code (ns);`	`gfc_generate_function_code (ns);`
`}`	`}`
`}`	`}`


`/* Drill down through expressions for the array specification bounds and`	`/* Drill down through expressions for the array specification bounds and`
`character length calling generate_local_decl for all those variables`	`character length calling generate_local_decl for all those variables`
`that have not already been declared. */`	`that have not already been declared. */`

`static void`	`static void`
`generate_local_decl (gfc_symbol *);`	`generate_local_decl (gfc_symbol *);`

`/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */`	`/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */`

`static bool`	`static bool`
`expr_decls (gfc_expr e, gfc_symbol sym,`	`expr_decls (gfc_expr e, gfc_symbol sym,`
`int *f ATTRIBUTE_UNUSED)`	`int *f ATTRIBUTE_UNUSED)`
`{`	`{`
`if (e->expr_type != EXPR_VARIABLE`	`if (e->expr_type != EXPR_VARIABLE`
`\|\| sym == e->symtree->n.sym`	`\|\| sym == e->symtree->n.sym`
`\|\| e->symtree->n.sym->mark`	`\|\| e->symtree->n.sym->mark`
`\|\| e->symtree->n.sym->ns != sym->ns)`	`\|\| e->symtree->n.sym->ns != sym->ns)`
`return false;`	`return false;`

`generate_local_decl (e->symtree->n.sym);`	`generate_local_decl (e->symtree->n.sym);`
`return false;`	`return false;`
`}`	`}`

`static void`	`static void`
`generate_expr_decls (gfc_symbol sym, gfc_expr e)`	`generate_expr_decls (gfc_symbol sym, gfc_expr e)`
`{`	`{`
`gfc_traverse_expr (e, sym, expr_decls, 0);`	`gfc_traverse_expr (e, sym, expr_decls, 0);`
`}`	`}`


`/* Check for dependencies in the character length and array spec. */`	`/* Check for dependencies in the character length and array spec. */`

`static void`	`static void`
`generate_dependency_declarations (gfc_symbol *sym)`	`generate_dependency_declarations (gfc_symbol *sym)`
`{`	`{`
`int i;`	`int i;`

`if (sym->ts.type == BT_CHARACTER`	`if (sym->ts.type == BT_CHARACTER`
`&& sym->ts.u.cl`	`&& sym->ts.u.cl`
`&& sym->ts.u.cl->length`	`&& sym->ts.u.cl->length`
`&& sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)`	`&& sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)`
`generate_expr_decls (sym, sym->ts.u.cl->length);`	`generate_expr_decls (sym, sym->ts.u.cl->length);`

`if (sym->as && sym->as->rank)`	`if (sym->as && sym->as->rank)`
`{`	`{`
`for (i = 0; i < sym->as->rank; i++)`	`for (i = 0; i < sym->as->rank; i++)`
`{`	`{`
`generate_expr_decls (sym, sym->as->lower[i]);`	`generate_expr_decls (sym, sym->as->lower[i]);`
`generate_expr_decls (sym, sym->as->upper[i]);`	`generate_expr_decls (sym, sym->as->upper[i]);`
`}`	`}`
`}`	`}`
`}`	`}`


`/* Generate decls for all local variables. We do this to ensure correct`	`/* Generate decls for all local variables. We do this to ensure correct`
`handling of expressions which only appear in the specification of`	`handling of expressions which only appear in the specification of`
`other functions. */`	`other functions. */`

`static void`	`static void`
`generate_local_decl (gfc_symbol * sym)`	`generate_local_decl (gfc_symbol * sym)`
`{`	`{`
`if (sym->attr.flavor == FL_VARIABLE)`	`if (sym->attr.flavor == FL_VARIABLE)`
`{`	`{`
`if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)`	`if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)`
`generate_dependency_declarations (sym);`	`generate_dependency_declarations (sym);`

`if (sym->attr.referenced)`	`if (sym->attr.referenced)`
`gfc_get_symbol_decl (sym);`	`gfc_get_symbol_decl (sym);`
`/* INTENT(out) dummy arguments are likely meant to be set. */`	`/* INTENT(out) dummy arguments are likely meant to be set. */`
`else if (warn_unused_variable`	`else if (warn_unused_variable`
`&& sym->attr.dummy`	`&& sym->attr.dummy`
`&& sym->attr.intent == INTENT_OUT)`	`&& sym->attr.intent == INTENT_OUT)`
`{`	`{`
`if (!(sym->ts.type == BT_DERIVED`	`if (!(sym->ts.type == BT_DERIVED`
`&& sym->ts.u.derived->components->initializer))`	`&& sym->ts.u.derived->components->initializer))`
`gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "`	`gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "`
`"but was not set", sym->name, &sym->declared_at);`	`"but was not set", sym->name, &sym->declared_at);`
`}`	`}`
`/* Specific warning for unused dummy arguments. */`	`/* Specific warning for unused dummy arguments. */`
`else if (warn_unused_variable && sym->attr.dummy)`	`else if (warn_unused_variable && sym->attr.dummy)`
`gfc_warning ("Unused dummy argument '%s' at %L", sym->name,`	`gfc_warning ("Unused dummy argument '%s' at %L", sym->name,`
`&sym->declared_at);`	`&sym->declared_at);`
`/* Warn for unused variables, but not if they're inside a common`	`/* Warn for unused variables, but not if they're inside a common`
`block or are use-associated. */`	`block or are use-associated. */`
`else if (warn_unused_variable`	`else if (warn_unused_variable`
`&& !(sym->attr.in_common \|\| sym->attr.use_assoc \|\| sym->mark))`	`&& !(sym->attr.in_common \|\| sym->attr.use_assoc \|\| sym->mark))`
`gfc_warning ("Unused variable '%s' declared at %L", sym->name,`	`gfc_warning ("Unused variable '%s' declared at %L", sym->name,`
`&sym->declared_at);`	`&sym->declared_at);`

`/* For variable length CHARACTER parameters, the PARM_DECL already`	`/* For variable length CHARACTER parameters, the PARM_DECL already`
`references the length variable, so force gfc_get_symbol_decl`	`references the length variable, so force gfc_get_symbol_decl`
`even when not referenced. If optimize > 0, it will be optimized`	`even when not referenced. If optimize > 0, it will be optimized`
`away anyway. But do this only after emitting -Wunused-parameter`	`away anyway. But do this only after emitting -Wunused-parameter`
`warning if requested. */`	`warning if requested. */`
`if (sym->attr.dummy && !sym->attr.referenced`	`if (sym->attr.dummy && !sym->attr.referenced`
`&& sym->ts.type == BT_CHARACTER`	`&& sym->ts.type == BT_CHARACTER`
`&& sym->ts.u.cl->backend_decl != NULL`	`&& sym->ts.u.cl->backend_decl != NULL`
`&& TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)`	`&& TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)`
`{`	`{`
`sym->attr.referenced = 1;`	`sym->attr.referenced = 1;`
`gfc_get_symbol_decl (sym);`	`gfc_get_symbol_decl (sym);`
`}`	`}`

`/* INTENT(out) dummy arguments and result variables with allocatable`	`/* INTENT(out) dummy arguments and result variables with allocatable`
`components are reset by default and need to be set referenced to`	`components are reset by default and need to be set referenced to`
`generate the code for nullification and automatic lengths. */`	`generate the code for nullification and automatic lengths. */`
`if (!sym->attr.referenced`	`if (!sym->attr.referenced`
`&& sym->ts.type == BT_DERIVED`	`&& sym->ts.type == BT_DERIVED`
`&& sym->ts.u.derived->attr.alloc_comp`	`&& sym->ts.u.derived->attr.alloc_comp`
`&& !sym->attr.pointer`	`&& !sym->attr.pointer`
`&& ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)`	`&& ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)`
`\|\|`	`\|\|`
`(sym->attr.result && sym != sym->result)))`	`(sym->attr.result && sym != sym->result)))`
`{`	`{`
`sym->attr.referenced = 1;`	`sym->attr.referenced = 1;`
`gfc_get_symbol_decl (sym);`	`gfc_get_symbol_decl (sym);`
`}`	`}`

`/* Check for dependencies in the array specification and string`	`/* Check for dependencies in the array specification and string`
`length, adding the necessary declarations to the function. We`	`length, adding the necessary declarations to the function. We`
`mark the symbol now, as well as in traverse_ns, to prevent`	`mark the symbol now, as well as in traverse_ns, to prevent`
`getting stuck in a circular dependency. */`	`getting stuck in a circular dependency. */`
`sym->mark = 1;`	`sym->mark = 1;`

`/* We do not want the middle-end to warn about unused parameters`	`/* We do not want the middle-end to warn about unused parameters`
`as this was already done above. */`	`as this was already done above. */`
`if (sym->attr.dummy && sym->backend_decl != NULL_TREE)`	`if (sym->attr.dummy && sym->backend_decl != NULL_TREE)`
`TREE_NO_WARNING(sym->backend_decl) = 1;`	`TREE_NO_WARNING(sym->backend_decl) = 1;`
`}`	`}`
`else if (sym->attr.flavor == FL_PARAMETER)`	`else if (sym->attr.flavor == FL_PARAMETER)`
`{`	`{`
`if (warn_unused_parameter`	`if (warn_unused_parameter`
`&& !sym->attr.referenced`	`&& !sym->attr.referenced`
`&& !sym->attr.use_assoc)`	`&& !sym->attr.use_assoc)`
`gfc_warning ("Unused parameter '%s' declared at %L", sym->name,`	`gfc_warning ("Unused parameter '%s' declared at %L", sym->name,`
`&sym->declared_at);`	`&sym->declared_at);`
`}`	`}`
`else if (sym->attr.flavor == FL_PROCEDURE)`	`else if (sym->attr.flavor == FL_PROCEDURE)`
`{`	`{`
`/* TODO: move to the appropriate place in resolve.c. */`	`/* TODO: move to the appropriate place in resolve.c. */`
`if (warn_return_type`	`if (warn_return_type`
`&& sym->attr.function`	`&& sym->attr.function`
`&& sym->result`	`&& sym->result`
`&& sym != sym->result`	`&& sym != sym->result`
`&& !sym->result->attr.referenced`	`&& !sym->result->attr.referenced`
`&& !sym->attr.use_assoc`	`&& !sym->attr.use_assoc`
`&& sym->attr.if_source != IFSRC_IFBODY)`	`&& sym->attr.if_source != IFSRC_IFBODY)`
`{`	`{`
`gfc_warning ("Return value '%s' of function '%s' declared at "`	`gfc_warning ("Return value '%s' of function '%s' declared at "`
`"%L not set", sym->result->name, sym->name,`	`"%L not set", sym->result->name, sym->name,`
`&sym->result->declared_at);`	`&sym->result->declared_at);`

`/* Prevents "Unused variable" warning for RESULT variables. */`	`/* Prevents "Unused variable" warning for RESULT variables. */`
`sym->result->mark = 1;`	`sym->result->mark = 1;`
`}`	`}`
`}`	`}`

`if (sym->attr.dummy == 1)`	`if (sym->attr.dummy == 1)`
`{`	`{`
`/* Modify the tree type for scalar character dummy arguments of bind(c)`	`/* Modify the tree type for scalar character dummy arguments of bind(c)`
`procedures if they are passed by value. The tree type for them will`	`procedures if they are passed by value. The tree type for them will`
`be promoted to INTEGER_TYPE for the middle end, which appears to be`	`be promoted to INTEGER_TYPE for the middle end, which appears to be`
`what C would do with characters passed by-value. The value attribute`	`what C would do with characters passed by-value. The value attribute`
`implies the dummy is a scalar. */`	`implies the dummy is a scalar. */`
`if (sym->attr.value == 1 && sym->backend_decl != NULL`	`if (sym->attr.value == 1 && sym->backend_decl != NULL`
`&& sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop`	`&& sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop`
`&& sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)`	`&& sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)`
`gfc_conv_scalar_char_value (sym, NULL, NULL);`	`gfc_conv_scalar_char_value (sym, NULL, NULL);`
`}`	`}`

`/* Make sure we convert the types of the derived types from iso_c_binding`	`/* Make sure we convert the types of the derived types from iso_c_binding`
`into (void ). /`	`into (void ). /`
`if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c`	`if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c`
`&& sym->ts.type == BT_DERIVED)`	`&& sym->ts.type == BT_DERIVED)`
`sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));`	`sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));`
`}`	`}`

`static void`	`static void`
`generate_local_vars (gfc_namespace * ns)`	`generate_local_vars (gfc_namespace * ns)`
`{`	`{`
`gfc_traverse_ns (ns, generate_local_decl);`	`gfc_traverse_ns (ns, generate_local_decl);`
`}`	`}`


`/* Generate a switch statement to jump to the correct entry point. Also`	`/* Generate a switch statement to jump to the correct entry point. Also`
`creates the label decls for the entry points. */`	`creates the label decls for the entry points. */`

`static tree`	`static tree`
`gfc_trans_entry_master_switch (gfc_entry_list * el)`	`gfc_trans_entry_master_switch (gfc_entry_list * el)`
`{`	`{`
`stmtblock_t block;`	`stmtblock_t block;`
`tree label;`	`tree label;`
`tree tmp;`	`tree tmp;`
`tree val;`	`tree val;`

`gfc_init_block (&block);`	`gfc_init_block (&block);`
`for (; el; el = el->next)`	`for (; el; el = el->next)`
`{`	`{`
`/* Add the case label. */`	`/* Add the case label. */`
`label = gfc_build_label_decl (NULL_TREE);`	`label = gfc_build_label_decl (NULL_TREE);`
`val = build_int_cst (gfc_array_index_type, el->id);`	`val = build_int_cst (gfc_array_index_type, el->id);`
`tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);`	`tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);`
`gfc_add_expr_to_block (&block, tmp);`	`gfc_add_expr_to_block (&block, tmp);`

`/* And jump to the actual entry point. */`	`/* And jump to the actual entry point. */`
`label = gfc_build_label_decl (NULL_TREE);`	`label = gfc_build_label_decl (NULL_TREE);`
`tmp = build1_v (GOTO_EXPR, label);`	`tmp = build1_v (GOTO_EXPR, label);`
`gfc_add_expr_to_block (&block, tmp);`	`gfc_add_expr_to_block (&block, tmp);`

`/* Save the label decl. */`	`/* Save the label decl. */`
`el->label = label;`	`el->label = label;`
`}`	`}`
`tmp = gfc_finish_block (&block);`	`tmp = gfc_finish_block (&block);`
`/* The first argument selects the entry point. */`	`/* The first argument selects the entry point. */`
`val = DECL_ARGUMENTS (current_function_decl);`	`val = DECL_ARGUMENTS (current_function_decl);`
`tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);`	`tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);`
`return tmp;`	`return tmp;`
`}`	`}`


`/* Add code to string lengths of actual arguments passed to a function against`	`/* Add code to string lengths of actual arguments passed to a function against`
`the expected lengths of the dummy arguments. */`	`the expected lengths of the dummy arguments. */`

`static void`	`static void`
`add_argument_checking (stmtblock_t block, gfc_symbol sym)`	`add_argument_checking (stmtblock_t block, gfc_symbol sym)`
`{`	`{`
`gfc_formal_arglist *formal;`	`gfc_formal_arglist *formal;`

`for (formal = sym->formal; formal; formal = formal->next)`	`for (formal = sym->formal; formal; formal = formal->next)`
`if (formal->sym && formal->sym->ts.type == BT_CHARACTER)`	`if (formal->sym && formal->sym->ts.type == BT_CHARACTER)`
`{`	`{`
`enum tree_code comparison;`	`enum tree_code comparison;`
`tree cond;`	`tree cond;`
`tree argname;`	`tree argname;`
`gfc_symbol *fsym;`	`gfc_symbol *fsym;`
`gfc_charlen *cl;`	`gfc_charlen *cl;`
`const char *message;`	`const char *message;`

`fsym = formal->sym;`	`fsym = formal->sym;`
`cl = fsym->ts.u.cl;`	`cl = fsym->ts.u.cl;`

`gcc_assert (cl);`	`gcc_assert (cl);`
`gcc_assert (cl->passed_length != NULL_TREE);`	`gcc_assert (cl->passed_length != NULL_TREE);`
`gcc_assert (cl->backend_decl != NULL_TREE);`	`gcc_assert (cl->backend_decl != NULL_TREE);`

`/* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the`	`/* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the`
`string lengths must match exactly. Otherwise, it is only required`	`string lengths must match exactly. Otherwise, it is only required`
`that the actual string length is at least the expected one.`	`that the actual string length is at least the expected one.`
`Sequence association allows for a mismatch of the string length`	`Sequence association allows for a mismatch of the string length`
`if the actual argument is (part of) an array, but only if the`	`if the actual argument is (part of) an array, but only if the`
`dummy argument is an array. (See "Sequence association" in`	`dummy argument is an array. (See "Sequence association" in`
`Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */`	`Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */`
`if (fsym->attr.pointer \|\| fsym->attr.allocatable`	`if (fsym->attr.pointer \|\| fsym->attr.allocatable`
`\|\| (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))`	`\|\| (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))`
`{`	`{`
`comparison = NE_EXPR;`	`comparison = NE_EXPR;`
`message = _("Actual string length does not match the declared one"`	`message = _("Actual string length does not match the declared one"`
`" for dummy argument '%s' (%ld/%ld)");`	`" for dummy argument '%s' (%ld/%ld)");`
`}`	`}`
`else if (fsym->as && fsym->as->rank != 0)`	`else if (fsym->as && fsym->as->rank != 0)`
`continue;`	`continue;`
`else`	`else`
`{`	`{`
`comparison = LT_EXPR;`	`comparison = LT_EXPR;`
`message = _("Actual string length is shorter than the declared one"`	`message = _("Actual string length is shorter than the declared one"`
`" for dummy argument '%s' (%ld/%ld)");`	`" for dummy argument '%s' (%ld/%ld)");`
`}`	`}`

`/* Build the condition. For optional arguments, an actual length`	`/* Build the condition. For optional arguments, an actual length`
`of 0 is also acceptable if the associated string is NULL, which`	`of 0 is also acceptable if the associated string is NULL, which`
`means the argument was not passed. */`	`means the argument was not passed. */`
`cond = fold_build2 (comparison, boolean_type_node,`	`cond = fold_build2 (comparison, boolean_type_node,`
`cl->passed_length, cl->backend_decl);`	`cl->passed_length, cl->backend_decl);`
`if (fsym->attr.optional)`	`if (fsym->attr.optional)`
`{`	`{`
`tree not_absent;`	`tree not_absent;`
`tree not_0length;`	`tree not_0length;`
`tree absent_failed;`	`tree absent_failed;`

`not_0length = fold_build2 (NE_EXPR, boolean_type_node,`	`not_0length = fold_build2 (NE_EXPR, boolean_type_node,`
`cl->passed_length,`	`cl->passed_length,`
`fold_convert (gfc_charlen_type_node,`	`fold_convert (gfc_charlen_type_node,`
`integer_zero_node));`	`integer_zero_node));`
`/* The symbol needs to be referenced for gfc_get_symbol_decl. */`	`/* The symbol needs to be referenced for gfc_get_symbol_decl. */`
`fsym->attr.referenced = 1;`	`fsym->attr.referenced = 1;`
`not_absent = gfc_conv_expr_present (fsym);`	`not_absent = gfc_conv_expr_present (fsym);`

`absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,`	`absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,`
`not_0length, not_absent);`	`not_0length, not_absent);`

`cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,`	`cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,`
`cond, absent_failed);`	`cond, absent_failed);`
`}`	`}`

`/* Build the runtime check. */`	`/* Build the runtime check. */`
`argname = gfc_build_cstring_const (fsym->name);`	`argname = gfc_build_cstring_const (fsym->name);`
`argname = gfc_build_addr_expr (pchar_type_node, argname);`	`argname = gfc_build_addr_expr (pchar_type_node, argname);`
`gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,`	`gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,`
`message, argname,`	`message, argname,`
`fold_convert (long_integer_type_node,`	`fold_convert (long_integer_type_node,`
`cl->passed_length),`	`cl->passed_length),`
`fold_convert (long_integer_type_node,`	`fold_convert (long_integer_type_node,`
`cl->backend_decl));`	`cl->backend_decl));`
`}`	`}`
`}`	`}`


`static void`	`static void`
`create_main_function (tree fndecl)`	`create_main_function (tree fndecl)`
`{`	`{`
`tree old_context;`	`tree old_context;`
`tree ftn_main;`	`tree ftn_main;`
`tree tmp, decl, result_decl, argc, argv, typelist, arglist;`	`tree tmp, decl, result_decl, argc, argv, typelist, arglist;`
`stmtblock_t body;`	`stmtblock_t body;`

`old_context = current_function_decl;`	`old_context = current_function_decl;`

`if (old_context)`	`if (old_context)`
`{`	`{`
`push_function_context ();`	`push_function_context ();`
`saved_parent_function_decls = saved_function_decls;`	`saved_parent_function_decls = saved_function_decls;`
`saved_function_decls = NULL_TREE;`	`saved_function_decls = NULL_TREE;`
`}`	`}`

`/* main() function must be declared with global scope. */`	`/* main() function must be declared with global scope. */`
`gcc_assert (current_function_decl == NULL_TREE);`	`gcc_assert (current_function_decl == NULL_TREE);`

`/* Declare the function. */`	`/* Declare the function. */`
`tmp = build_function_type_list (integer_type_node, integer_type_node,`	`tmp = build_function_type_list (integer_type_node, integer_type_node,`
`build_pointer_type (pchar_type_node),`	`build_pointer_type (pchar_type_node),`
`NULL_TREE);`	`NULL_TREE);`
`main_identifier_node = get_identifier ("main");`	`main_identifier_node = get_identifier ("main");`
`ftn_main = build_decl (input_location, FUNCTION_DECL,`	`ftn_main = build_decl (input_location, FUNCTION_DECL,`
`main_identifier_node, tmp);`	`main_identifier_node, tmp);`
`DECL_EXTERNAL (ftn_main) = 0;`	`DECL_EXTERNAL (ftn_main) = 0;`
`TREE_PUBLIC (ftn_main) = 1;`	`TREE_PUBLIC (ftn_main) = 1;`
`TREE_STATIC (ftn_main) = 1;`	`TREE_STATIC (ftn_main) = 1;`
`DECL_ATTRIBUTES (ftn_main)`	`DECL_ATTRIBUTES (ftn_main)`
`= tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);`	`= tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);`

`/* Setup the result declaration (for "return 0"). */`	`/* Setup the result declaration (for "return 0"). */`
`result_decl = build_decl (input_location,`	`result_decl = build_decl (input_location,`
`RESULT_DECL, NULL_TREE, integer_type_node);`	`RESULT_DECL, NULL_TREE, integer_type_node);`
`DECL_ARTIFICIAL (result_decl) = 1;`	`DECL_ARTIFICIAL (result_decl) = 1;`
`DECL_IGNORED_P (result_decl) = 1;`	`DECL_IGNORED_P (result_decl) = 1;`
`DECL_CONTEXT (result_decl) = ftn_main;`	`DECL_CONTEXT (result_decl) = ftn_main;`
`DECL_RESULT (ftn_main) = result_decl;`	`DECL_RESULT (ftn_main) = result_decl;`

`pushdecl (ftn_main);`	`pushdecl (ftn_main);`

`/* Get the arguments. */`	`/* Get the arguments. */`

`arglist = NULL_TREE;`	`arglist = NULL_TREE;`
`typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));`	`typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));`

`tmp = TREE_VALUE (typelist);`	`tmp = TREE_VALUE (typelist);`
`argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);`	`argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);`
`DECL_CONTEXT (argc) = ftn_main;`	`DECL_CONTEXT (argc) = ftn_main;`
`DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);`	`DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);`
`TREE_READONLY (argc) = 1;`	`TREE_READONLY (argc) = 1;`
`gfc_finish_decl (argc);`	`gfc_finish_decl (argc);`
`arglist = chainon (arglist, argc);`	`arglist = chainon (arglist, argc);`

`typelist = TREE_CHAIN (typelist);`	`typelist = TREE_CHAIN (typelist);`
`tmp = TREE_VALUE (typelist);`	`tmp = TREE_VALUE (typelist);`
`argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);`	`argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);`
`DECL_CONTEXT (argv) = ftn_main;`	`DECL_CONTEXT (argv) = ftn_main;`
`DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);`	`DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);`
`TREE_READONLY (argv) = 1;`	`TREE_READONLY (argv) = 1;`
`DECL_BY_REFERENCE (argv) = 1;`	`DECL_BY_REFERENCE (argv) = 1;`
`gfc_finish_decl (argv);`	`gfc_finish_decl (argv);`
`arglist = chainon (arglist, argv);`	`arglist = chainon (arglist, argv);`

`DECL_ARGUMENTS (ftn_main) = arglist;`	`DECL_ARGUMENTS (ftn_main) = arglist;`
`current_function_decl = ftn_main;`	`current_function_decl = ftn_main;`
`announce_function (ftn_main);`	`announce_function (ftn_main);`

`rest_of_decl_compilation (ftn_main, 1, 0);`	`rest_of_decl_compilation (ftn_main, 1, 0);`
`make_decl_rtl (ftn_main);`	`make_decl_rtl (ftn_main);`
`init_function_start (ftn_main);`	`init_function_start (ftn_main);`
`pushlevel (0);`	`pushlevel (0);`

`gfc_init_block (&body);`	`gfc_init_block (&body);`

`/* Call some libgfortran initialization routines, call then MAIN__(). */`	`/* Call some libgfortran initialization routines, call then MAIN__(). */`

`/* Call _gfortran_set_args (argc, argv). */`	`/* Call _gfortran_set_args (argc, argv). */`
`TREE_USED (argc) = 1;`	`TREE_USED (argc) = 1;`
`TREE_USED (argv) = 1;`	`TREE_USED (argv) = 1;`
`tmp = build_call_expr_loc (input_location,`	`tmp = build_call_expr_loc (input_location,`
`gfor_fndecl_set_args, 2, argc, argv);`	`gfor_fndecl_set_args, 2, argc, argv);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`

`/* Add a call to set_options to set up the runtime library Fortran`	`/* Add a call to set_options to set up the runtime library Fortran`
`language standard parameters. */`	`language standard parameters. */`
`{`	`{`
`tree array_type, array, var;`	`tree array_type, array, var;`

`/* Passing a new option to the library requires four modifications:`	`/* Passing a new option to the library requires four modifications:`
`+ add it to the tree_cons list below`	`+ add it to the tree_cons list below`
`+ change the array size in the call to build_array_type`	`+ change the array size in the call to build_array_type`
`+ change the first argument to the library call`	`+ change the first argument to the library call`
`gfor_fndecl_set_options`	`gfor_fndecl_set_options`
`+ modify the library (runtime/compile_options.c)! */`	`+ modify the library (runtime/compile_options.c)! */`

`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`	`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`
`gfc_option.warn_std), NULL_TREE);`	`gfc_option.warn_std), NULL_TREE);`
`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`	`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`
`gfc_option.allow_std), array);`	`gfc_option.allow_std), array);`
`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),`	`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),`
`array);`	`array);`
`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`	`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`
`gfc_option.flag_dump_core), array);`	`gfc_option.flag_dump_core), array);`
`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`	`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`
`gfc_option.flag_backtrace), array);`	`gfc_option.flag_backtrace), array);`
`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`	`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`
`gfc_option.flag_sign_zero), array);`	`gfc_option.flag_sign_zero), array);`

`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`	`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`
`(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);`	`(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);`

`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`	`array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,`
`gfc_option.flag_range_check), array);`	`gfc_option.flag_range_check), array);`

`array_type = build_array_type (integer_type_node,`	`array_type = build_array_type (integer_type_node,`
`build_index_type (build_int_cst (NULL_TREE, 7)));`	`build_index_type (build_int_cst (NULL_TREE, 7)));`
`array = build_constructor_from_list (array_type, nreverse (array));`	`array = build_constructor_from_list (array_type, nreverse (array));`
`TREE_CONSTANT (array) = 1;`	`TREE_CONSTANT (array) = 1;`
`TREE_STATIC (array) = 1;`	`TREE_STATIC (array) = 1;`

`/* Create a static variable to hold the jump table. */`	`/* Create a static variable to hold the jump table. */`
`var = gfc_create_var (array_type, "options");`	`var = gfc_create_var (array_type, "options");`
`TREE_CONSTANT (var) = 1;`	`TREE_CONSTANT (var) = 1;`
`TREE_STATIC (var) = 1;`	`TREE_STATIC (var) = 1;`
`TREE_READONLY (var) = 1;`	`TREE_READONLY (var) = 1;`
`DECL_INITIAL (var) = array;`	`DECL_INITIAL (var) = array;`
`var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);`	`var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);`

`tmp = build_call_expr_loc (input_location,`	`tmp = build_call_expr_loc (input_location,`
`gfor_fndecl_set_options, 2,`	`gfor_fndecl_set_options, 2,`
`build_int_cst (integer_type_node, 8), var);`	`build_int_cst (integer_type_node, 8), var);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`
`}`	`}`

`/* If -ffpe-trap option was provided, add a call to set_fpe so that`	`/* If -ffpe-trap option was provided, add a call to set_fpe so that`
`the library will raise a FPE when needed. */`	`the library will raise a FPE when needed. */`
`if (gfc_option.fpe != 0)`	`if (gfc_option.fpe != 0)`
`{`	`{`
`tmp = build_call_expr_loc (input_location,`	`tmp = build_call_expr_loc (input_location,`
`gfor_fndecl_set_fpe, 1,`	`gfor_fndecl_set_fpe, 1,`
`build_int_cst (integer_type_node,`	`build_int_cst (integer_type_node,`
`gfc_option.fpe));`	`gfc_option.fpe));`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`
`}`	`}`

`/* If this is the main program and an -fconvert option was provided,`	`/* If this is the main program and an -fconvert option was provided,`
`add a call to set_convert. */`	`add a call to set_convert. */`

`if (gfc_option.convert != GFC_CONVERT_NATIVE)`	`if (gfc_option.convert != GFC_CONVERT_NATIVE)`
`{`	`{`
`tmp = build_call_expr_loc (input_location,`	`tmp = build_call_expr_loc (input_location,`
`gfor_fndecl_set_convert, 1,`	`gfor_fndecl_set_convert, 1,`
`build_int_cst (integer_type_node,`	`build_int_cst (integer_type_node,`
`gfc_option.convert));`	`gfc_option.convert));`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`
`}`	`}`

`/* If this is the main program and an -frecord-marker option was provided,`	`/* If this is the main program and an -frecord-marker option was provided,`
`add a call to set_record_marker. */`	`add a call to set_record_marker. */`

`if (gfc_option.record_marker != 0)`	`if (gfc_option.record_marker != 0)`
`{`	`{`
`tmp = build_call_expr_loc (input_location,`	`tmp = build_call_expr_loc (input_location,`
`gfor_fndecl_set_record_marker, 1,`	`gfor_fndecl_set_record_marker, 1,`
`build_int_cst (integer_type_node,`	`build_int_cst (integer_type_node,`
`gfc_option.record_marker));`	`gfc_option.record_marker));`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`
`}`	`}`

`if (gfc_option.max_subrecord_length != 0)`	`if (gfc_option.max_subrecord_length != 0)`
`{`	`{`
`tmp = build_call_expr_loc (input_location,`	`tmp = build_call_expr_loc (input_location,`
`gfor_fndecl_set_max_subrecord_length, 1,`	`gfor_fndecl_set_max_subrecord_length, 1,`
`build_int_cst (integer_type_node,`	`build_int_cst (integer_type_node,`
`gfc_option.max_subrecord_length));`	`gfc_option.max_subrecord_length));`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`
`}`	`}`

`/* Call MAIN__(). */`	`/* Call MAIN__(). */`
`tmp = build_call_expr_loc (input_location,`	`tmp = build_call_expr_loc (input_location,`
`fndecl, 0);`	`fndecl, 0);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`

`/* Mark MAIN__ as used. */`	`/* Mark MAIN__ as used. */`
`TREE_USED (fndecl) = 1;`	`TREE_USED (fndecl) = 1;`

`/* "return 0". */`	`/* "return 0". */`
`tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),`	`tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),`
`build_int_cst (integer_type_node, 0));`	`build_int_cst (integer_type_node, 0));`
`tmp = build1_v (RETURN_EXPR, tmp);`	`tmp = build1_v (RETURN_EXPR, tmp);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`


`DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);`	`DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);`
`decl = getdecls ();`	`decl = getdecls ();`

`/* Finish off this function and send it for code generation. */`	`/* Finish off this function and send it for code generation. */`
`poplevel (1, 0, 1);`	`poplevel (1, 0, 1);`
`BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;`	`BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;`

`DECL_SAVED_TREE (ftn_main)`	`DECL_SAVED_TREE (ftn_main)`
`= build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),`	`= build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),`
`DECL_INITIAL (ftn_main));`	`DECL_INITIAL (ftn_main));`

`/* Output the GENERIC tree. */`	`/* Output the GENERIC tree. */`
`dump_function (TDI_original, ftn_main);`	`dump_function (TDI_original, ftn_main);`

`cgraph_finalize_function (ftn_main, true);`	`cgraph_finalize_function (ftn_main, true);`

`if (old_context)`	`if (old_context)`
`{`	`{`
`pop_function_context ();`	`pop_function_context ();`
`saved_function_decls = saved_parent_function_decls;`	`saved_function_decls = saved_parent_function_decls;`
`}`	`}`
`current_function_decl = old_context;`	`current_function_decl = old_context;`
`}`	`}`


`/* Generate code for a function. */`	`/* Generate code for a function. */`

`void`	`void`
`gfc_generate_function_code (gfc_namespace * ns)`	`gfc_generate_function_code (gfc_namespace * ns)`
`{`	`{`
`tree fndecl;`	`tree fndecl;`
`tree old_context;`	`tree old_context;`
`tree decl;`	`tree decl;`
`tree tmp;`	`tree tmp;`
`tree tmp2;`	`tree tmp2;`
`stmtblock_t block;`	`stmtblock_t block;`
`stmtblock_t body;`	`stmtblock_t body;`
`tree result;`	`tree result;`
`tree recurcheckvar = NULL_TREE;`	`tree recurcheckvar = NULL_TREE;`
`gfc_symbol *sym;`	`gfc_symbol *sym;`
`int rank;`	`int rank;`
`bool is_recursive;`	`bool is_recursive;`

`sym = ns->proc_name;`	`sym = ns->proc_name;`

`/* Check that the frontend isn't still using this. */`	`/* Check that the frontend isn't still using this. */`
`gcc_assert (sym->tlink == NULL);`	`gcc_assert (sym->tlink == NULL);`
`sym->tlink = sym;`	`sym->tlink = sym;`

`/* Create the declaration for functions with global scope. */`	`/* Create the declaration for functions with global scope. */`
`if (!sym->backend_decl)`	`if (!sym->backend_decl)`
`gfc_create_function_decl (ns);`	`gfc_create_function_decl (ns);`

`fndecl = sym->backend_decl;`	`fndecl = sym->backend_decl;`
`old_context = current_function_decl;`	`old_context = current_function_decl;`

`if (old_context)`	`if (old_context)`
`{`	`{`
`push_function_context ();`	`push_function_context ();`
`saved_parent_function_decls = saved_function_decls;`	`saved_parent_function_decls = saved_function_decls;`
`saved_function_decls = NULL_TREE;`	`saved_function_decls = NULL_TREE;`
`}`	`}`

`trans_function_start (sym);`	`trans_function_start (sym);`

`gfc_init_block (&block);`	`gfc_init_block (&block);`

`if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)`	`if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)`
`{`	`{`
`/* Copy length backend_decls to all entry point result`	`/* Copy length backend_decls to all entry point result`
`symbols. */`	`symbols. */`
`gfc_entry_list *el;`	`gfc_entry_list *el;`
`tree backend_decl;`	`tree backend_decl;`

`gfc_conv_const_charlen (ns->proc_name->ts.u.cl);`	`gfc_conv_const_charlen (ns->proc_name->ts.u.cl);`
`backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;`	`backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;`
`for (el = ns->entries; el; el = el->next)`	`for (el = ns->entries; el; el = el->next)`
`el->sym->result->ts.u.cl->backend_decl = backend_decl;`	`el->sym->result->ts.u.cl->backend_decl = backend_decl;`
`}`	`}`

`/* Translate COMMON blocks. */`	`/* Translate COMMON blocks. */`
`gfc_trans_common (ns);`	`gfc_trans_common (ns);`

`/* Null the parent fake result declaration if this namespace is`	`/* Null the parent fake result declaration if this namespace is`
`a module function or an external procedures. */`	`a module function or an external procedures. */`
`if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)`	`if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)`
`\|\| ns->parent == NULL)`	`\|\| ns->parent == NULL)`
`parent_fake_result_decl = NULL_TREE;`	`parent_fake_result_decl = NULL_TREE;`

`gfc_generate_contained_functions (ns);`	`gfc_generate_contained_functions (ns);`

`nonlocal_dummy_decls = NULL;`	`nonlocal_dummy_decls = NULL;`
`nonlocal_dummy_decl_pset = NULL;`	`nonlocal_dummy_decl_pset = NULL;`

`generate_local_vars (ns);`	`generate_local_vars (ns);`

`/* Keep the parent fake result declaration in module functions`	`/* Keep the parent fake result declaration in module functions`
`or external procedures. */`	`or external procedures. */`
`if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)`	`if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)`
`\|\| ns->parent == NULL)`	`\|\| ns->parent == NULL)`
`current_fake_result_decl = parent_fake_result_decl;`	`current_fake_result_decl = parent_fake_result_decl;`
`else`	`else`
`current_fake_result_decl = NULL_TREE;`	`current_fake_result_decl = NULL_TREE;`

`current_function_return_label = NULL;`	`current_function_return_label = NULL;`

`/* Now generate the code for the body of this function. */`	`/* Now generate the code for the body of this function. */`
`gfc_init_block (&body);`	`gfc_init_block (&body);`

`is_recursive = sym->attr.recursive`	`is_recursive = sym->attr.recursive`
`\|\| (sym->attr.entry_master`	`\|\| (sym->attr.entry_master`
`&& sym->ns->entries->sym->attr.recursive);`	`&& sym->ns->entries->sym->attr.recursive);`
`if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)`	`if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)`
`&& !is_recursive`	`&& !is_recursive`
`&& !gfc_option.flag_recursive)`	`&& !gfc_option.flag_recursive)`
`{`	`{`
`char * msg;`	`char * msg;`

`asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",`	`asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",`
`sym->name);`	`sym->name);`
`recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");`	`recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");`
`TREE_STATIC (recurcheckvar) = 1;`	`TREE_STATIC (recurcheckvar) = 1;`
`DECL_INITIAL (recurcheckvar) = boolean_false_node;`	`DECL_INITIAL (recurcheckvar) = boolean_false_node;`
`gfc_add_expr_to_block (&block, recurcheckvar);`	`gfc_add_expr_to_block (&block, recurcheckvar);`
`gfc_trans_runtime_check (true, false, recurcheckvar, &block,`	`gfc_trans_runtime_check (true, false, recurcheckvar, &block,`
`&sym->declared_at, msg);`	`&sym->declared_at, msg);`
`gfc_add_modify (&block, recurcheckvar, boolean_true_node);`	`gfc_add_modify (&block, recurcheckvar, boolean_true_node);`
`gfc_free (msg);`	`gfc_free (msg);`
`}`	`}`

`if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node`	`if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node`
`&& sym->attr.subroutine)`	`&& sym->attr.subroutine)`
`{`	`{`
`tree alternate_return;`	`tree alternate_return;`
`alternate_return = gfc_get_fake_result_decl (sym, 0);`	`alternate_return = gfc_get_fake_result_decl (sym, 0);`
`gfc_add_modify (&body, alternate_return, integer_zero_node);`	`gfc_add_modify (&body, alternate_return, integer_zero_node);`
`}`	`}`

`if (ns->entries)`	`if (ns->entries)`
`{`	`{`
`/* Jump to the correct entry point. */`	`/* Jump to the correct entry point. */`
`tmp = gfc_trans_entry_master_switch (ns->entries);`	`tmp = gfc_trans_entry_master_switch (ns->entries);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`
`}`	`}`

`/* If bounds-checking is enabled, generate code to check passed in actual`	`/* If bounds-checking is enabled, generate code to check passed in actual`
`arguments against the expected dummy argument attributes (e.g. string`	`arguments against the expected dummy argument attributes (e.g. string`
`lengths). */`	`lengths). */`
`if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)`	`if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)`
`add_argument_checking (&body, sym);`	`add_argument_checking (&body, sym);`

`tmp = gfc_trans_code (ns->code);`	`tmp = gfc_trans_code (ns->code);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`

`/* Add a return label if needed. */`	`/* Add a return label if needed. */`
`if (current_function_return_label)`	`if (current_function_return_label)`
`{`	`{`
`tmp = build1_v (LABEL_EXPR, current_function_return_label);`	`tmp = build1_v (LABEL_EXPR, current_function_return_label);`
`gfc_add_expr_to_block (&body, tmp);`	`gfc_add_expr_to_block (&body, tmp);`
`}`	`}`

`tmp = gfc_finish_block (&body);`	`tmp = gfc_finish_block (&body);`
`/* Add code to create and cleanup arrays. */`	`/* Add code to create and cleanup arrays. */`
`tmp = gfc_trans_deferred_vars (sym, tmp);`	`tmp = gfc_trans_deferred_vars (sym, tmp);`

`if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)`	`if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)`
`{`	`{`
`if (sym->attr.subroutine \|\| sym == sym->result)`	`if (sym->attr.subroutine \|\| sym == sym->result)`
`{`	`{`
`if (current_fake_result_decl != NULL)`	`if (current_fake_result_decl != NULL)`
`result = TREE_VALUE (current_fake_result_decl);`	`result = TREE_VALUE (current_fake_result_decl);`
`else`	`else`
`result = NULL_TREE;`	`result = NULL_TREE;`
`current_fake_result_decl = NULL_TREE;`	`current_fake_result_decl = NULL_TREE;`
`}`	`}`
`else`	`else`
`result = sym->result->backend_decl;`	`result = sym->result->backend_decl;`

`if (result != NULL_TREE`	`if (result != NULL_TREE`
`&& sym->attr.function`	`&& sym->attr.function`
`&& !sym->attr.pointer)`	`&& !sym->attr.pointer)`
`{`	`{`
`if (sym->ts.type == BT_DERIVED`	`if (sym->ts.type == BT_DERIVED`
`&& sym->ts.u.derived->attr.alloc_comp)`	`&& sym->ts.u.derived->attr.alloc_comp)`
`{`	`{`
`rank = sym->as ? sym->as->rank : 0;`	`rank = sym->as ? sym->as->rank : 0;`
`tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);`	`tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);`
`gfc_add_expr_to_block (&block, tmp2);`	`gfc_add_expr_to_block (&block, tmp2);`
`}`	`}`
`else if (sym->attr.allocatable && sym->attr.dimension == 0)`	`else if (sym->attr.allocatable && sym->attr.dimension == 0)`
`gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),`	`gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),`
`null_pointer_node));`	`null_pointer_node));`
`}`	`}`

`gfc_add_expr_to_block (&block, tmp);`	`gfc_add_expr_to_block (&block, tmp);`

`/* Reset recursion-check variable. */`	`/* Reset recursion-check variable. */`
`if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)`	`if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)`
`&& !is_recursive`	`&& !is_recursive`
`&& !gfc_option.flag_openmp`	`&& !gfc_option.flag_openmp`
`&& recurcheckvar != NULL_TREE)`	`&& recurcheckvar != NULL_TREE)`
`{`	`{`
`gfc_add_modify (&block, recurcheckvar, boolean_false_node);`	`gfc_add_modify (&block, recurcheckvar, boolean_false_node);`
`recurcheckvar = NULL;`	`recurcheckvar = NULL;`
`}`	`}`

`if (result == NULL_TREE)`	`if (result == NULL_TREE)`
`{`	`{`
`/* TODO: move to the appropriate place in resolve.c. */`	`/* TODO: move to the appropriate place in resolve.c. */`
`if (warn_return_type && !sym->attr.referenced && sym == sym->result)`	`if (warn_return_type && !sym->attr.referenced && sym == sym->result)`
`gfc_warning ("Return value of function '%s' at %L not set",`	`gfc_warning ("Return value of function '%s' at %L not set",`
`sym->name, &sym->declared_at);`	`sym->name, &sym->declared_at);`

`TREE_NO_WARNING(sym->backend_decl) = 1;`	`TREE_NO_WARNING(sym->backend_decl) = 1;`
`}`	`}`
`else`	`else`
`{`	`{`
`/* Set the return value to the dummy result variable. The`	`/* Set the return value to the dummy result variable. The`
`types may be different for scalar default REAL functions`	`types may be different for scalar default REAL functions`
`with -ff2c, therefore we have to convert. */`	`with -ff2c, therefore we have to convert. */`
`tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);`	`tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);`
`tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),`	`tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),`
`DECL_RESULT (fndecl), tmp);`	`DECL_RESULT (fndecl), tmp);`
`tmp = build1_v (RETURN_EXPR, tmp);`	`tmp = build1_v (RETURN_EXPR, tmp);`
`gfc_add_expr_to_block (&block, tmp);`	`gfc_add_expr_to_block (&block, tmp);`
`}`	`}`
`}`	`}`
`else`	`else`
`{`	`{`
`gfc_add_expr_to_block (&block, tmp);`	`gfc_add_expr_to_block (&block, tmp);`
`/* Reset recursion-check variable. */`	`/* Reset recursion-check variable. */`
`if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)`	`if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)`
`&& !is_recursive`	`&& !is_recursive`
`&& !gfc_option.flag_openmp`	`&& !gfc_option.flag_openmp`
`&& recurcheckvar != NULL_TREE)`	`&& recurcheckvar != NULL_TREE)`
`{`	`{`
`gfc_add_modify (&block, recurcheckvar, boolean_false_node);`	`gfc_add_modify (&block, recurcheckvar, boolean_false_node);`
`recurcheckvar = NULL_TREE;`	`recurcheckvar = NULL_TREE;`
`}`	`}`
`}`	`}`


`/* Add all the decls we created during processing. */`	`/* Add all the decls we created during processing. */`
`decl = saved_function_decls;`	`decl = saved_function_decls;`
`while (decl)`	`while (decl)`
`{`	`{`
`tree next;`	`tree next;`

`next = TREE_CHAIN (decl);`	`next = TREE_CHAIN (decl);`
`TREE_CHAIN (decl) = NULL_TREE;`	`TREE_CHAIN (decl) = NULL_TREE;`
`pushdecl (decl);`	`pushdecl (decl);`
`decl = next;`	`decl = next;`
`}`	`}`
`saved_function_decls = NULL_TREE;`	`saved_function_decls = NULL_TREE;`

`DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);`	`DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);`
`decl = getdecls ();`	`decl = getdecls ();`

`/* Finish off this function and send it for code generation. */`	`/* Finish off this function and send it for code generation. */`
`poplevel (1, 0, 1);`	`poplevel (1, 0, 1);`
`BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;`	`BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;`

`DECL_SAVED_TREE (fndecl)`	`DECL_SAVED_TREE (fndecl)`
`= build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),`	`= build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),`
`DECL_INITIAL (fndecl));`	`DECL_INITIAL (fndecl));`

`if (nonlocal_dummy_decls)`	`if (nonlocal_dummy_decls)`
`{`	`{`
`BLOCK_VARS (DECL_INITIAL (fndecl))`	`BLOCK_VARS (DECL_INITIAL (fndecl))`
`= chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);`	`= chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);`
`pointer_set_destroy (nonlocal_dummy_decl_pset);`	`pointer_set_destroy (nonlocal_dummy_decl_pset);`
`nonlocal_dummy_decls = NULL;`	`nonlocal_dummy_decls = NULL;`
`nonlocal_dummy_decl_pset = NULL;`	`nonlocal_dummy_decl_pset = NULL;`
`}`	`}`

`/* Output the GENERIC tree. */`	`/* Output the GENERIC tree. */`
`dump_function (TDI_original, fndecl);`	`dump_function (TDI_original, fndecl);`

`/* Store the end of the function, so that we get good line number`	`/* Store the end of the function, so that we get good line number`
`info for the epilogue. */`	`info for the epilogue. */`
`cfun->function_end_locus = input_location;`	`cfun->function_end_locus = input_location;`

`/* We're leaving the context of this function, so zap cfun.`	`/* We're leaving the context of this function, so zap cfun.`
`It's still in DECL_STRUCT_FUNCTION, and we'll restore it in`	`It's still in DECL_STRUCT_FUNCTION, and we'll restore it in`
`tree_rest_of_compilation. */`	`tree_rest_of_compilation. */`
`set_cfun (NULL);`	`set_cfun (NULL);`

`if (old_context)`	`if (old_context)`
`{`	`{`
`pop_function_context ();`	`pop_function_context ();`
`saved_function_decls = saved_parent_function_decls;`	`saved_function_decls = saved_parent_function_decls;`
`}`	`}`
`current_function_decl = old_context;`	`current_function_decl = old_context;`

`if (decl_function_context (fndecl))`	`if (decl_function_context (fndecl))`
`/* Register this function with cgraph just far enough to get it`	`/* Register this function with cgraph just far enough to get it`
`added to our parent's nested function list. */`	`added to our parent's nested function list. */`
`(void) cgraph_node (fndecl);`	`(void) cgraph_node (fndecl);`
`else`	`else`
`cgraph_finalize_function (fndecl, true);`	`cgraph_finalize_function (fndecl, true);`

`gfc_trans_use_stmts (ns);`	`gfc_trans_use_stmts (ns);`
`gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);`	`gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);`

`if (sym->attr.is_main_program)`	`if (sym->attr.is_main_program)`
`create_main_function (fndecl);`	`create_main_function (fndecl);`
`}`	`}`


`void`	`void`
`gfc_generate_constructors (void)`	`gfc_generate_constructors (void)`
`{`	`{`
`gcc_assert (gfc_static_ctors == NULL_TREE);`	`gcc_assert (gfc_static_ctors == NULL_TREE);`
`#if 0`	`#if 0`
`tree fnname;`	`tree fnname;`
`tree type;`	`tree type;`
`tree fndecl;`	`tree fndecl;`
`tree decl;`	`tree decl;`
`tree tmp;`	`tree tmp;`

`if (gfc_static_ctors == NULL_TREE)`	`if (gfc_static_ctors == NULL_TREE)`
`return;`	`return;`

`fnname = get_file_function_name ("I");`	`fnname = get_file_function_name ("I");`
`type = build_function_type (void_type_node,`	`type = build_function_type (void_type_node,`
`gfc_chainon_list (NULL_TREE, void_type_node));`	`gfc_chainon_list (NULL_TREE, void_type_node));`

`fndecl = build_decl (input_location,`	`fndecl = build_decl (input_location,`
`FUNCTION_DECL, fnname, type);`	`FUNCTION_DECL, fnname, type);`
`TREE_PUBLIC (fndecl) = 1;`	`TREE_PUBLIC (fndecl) = 1;`

`decl = build_decl (input_location,`	`decl = build_decl (input_location,`
`RESULT_DECL, NULL_TREE, void_type_node);`	`RESULT_DECL, NULL_TREE, void_type_node);`
`DECL_ARTIFICIAL (decl) = 1;`	`DECL_ARTIFICIAL (decl) = 1;`
`DECL_IGNORED_P (decl) = 1;`	`DECL_IGNORED_P (decl) = 1;`
`DECL_CONTEXT (decl) = fndecl;`	`DECL_CONTEXT (decl) = fndecl;`
`DECL_RESULT (fndecl) = decl;`	`DECL_RESULT (fndecl) = decl;`

`pushdecl (fndecl);`	`pushdecl (fndecl);`

`current_function_decl = fndecl;`	`current_function_decl = fndecl;`

`rest_of_decl_compilation (fndecl, 1, 0);`	`rest_of_decl_compilation (fndecl, 1, 0);`

`make_decl_rtl (fndecl);`	`make_decl_rtl (fndecl);`

`init_function_start (fndecl);`	`init_function_start (fndecl);`

`pushlevel (0);`	`pushlevel (0);`

`for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))`	`for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))`
`{`	`{`
`tmp = build_call_expr_loc (input_location,`	`tmp = build_call_expr_loc (input_location,`
`TREE_VALUE (gfc_static_ctors), 0);`	`TREE_VALUE (gfc_static_ctors), 0);`
`DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);`	`DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);`
`}`	`}`

`decl = getdecls ();`	`decl = getdecls ();`
`poplevel (1, 0, 1);`	`poplevel (1, 0, 1);`

`BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;`	`BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;`
`DECL_SAVED_TREE (fndecl)`	`DECL_SAVED_TREE (fndecl)`
`= build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),`	`= build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),`
`DECL_INITIAL (fndecl));`	`DECL_INITIAL (fndecl));`

`free_after_parsing (cfun);`	`free_after_parsing (cfun);`
`free_after_compilation (cfun);`	`free_after_compilation (cfun);`

`tree_rest_of_compilation (fndecl);`	`tree_rest_of_compilation (fndecl);`

`current_function_decl = NULL_TREE;`	`current_function_decl = NULL_TREE;`
`#endif`	`#endif`
`}`	`}`

`/* Translates a BLOCK DATA program unit. This means emitting the`	`/* Translates a BLOCK DATA program unit. This means emitting the`
`commons contained therein plus their initializations. We also emit`	`commons contained therein plus their initializations. We also emit`
`a globally visible symbol to make sure that each BLOCK DATA program`	`a globally visible symbol to make sure that each BLOCK DATA program`
`unit remains unique. */`	`unit remains unique. */`

`void`	`void`
`gfc_generate_block_data (gfc_namespace * ns)`	`gfc_generate_block_data (gfc_namespace * ns)`
`{`	`{`
`tree decl;`	`tree decl;`
`tree id;`	`tree id;`

`/* Tell the backend the source location of the block data. */`	`/* Tell the backend the source location of the block data. */`
`if (ns->proc_name)`	`if (ns->proc_name)`
`gfc_set_backend_locus (&ns->proc_name->declared_at);`	`gfc_set_backend_locus (&ns->proc_name->declared_at);`
`else`	`else`
`gfc_set_backend_locus (&gfc_current_locus);`	`gfc_set_backend_locus (&gfc_current_locus);`

`/* Process the DATA statements. */`	`/* Process the DATA statements. */`
`gfc_trans_common (ns);`	`gfc_trans_common (ns);`

`/* Create a global symbol with the mane of the block data. This is to`	`/* Create a global symbol with the mane of the block data. This is to`
`generate linker errors if the same name is used twice. It is never`	`generate linker errors if the same name is used twice. It is never`
`really used. */`	`really used. */`
`if (ns->proc_name)`	`if (ns->proc_name)`
`id = gfc_sym_mangled_function_id (ns->proc_name);`	`id = gfc_sym_mangled_function_id (ns->proc_name);`
`else`	`else`
`id = get_identifier ("__BLOCK_DATA__");`	`id = get_identifier ("__BLOCK_DATA__");`

`decl = build_decl (input_location,`	`decl = build_decl (input_location,`
`VAR_DECL, id, gfc_array_index_type);`	`VAR_DECL, id, gfc_array_index_type);`
`TREE_PUBLIC (decl) = 1;`	`TREE_PUBLIC (decl) = 1;`
`TREE_STATIC (decl) = 1;`	`TREE_STATIC (decl) = 1;`
`DECL_IGNORED_P (decl) = 1;`	`DECL_IGNORED_P (decl) = 1;`

`pushdecl (decl);`	`pushdecl (decl);`
`rest_of_decl_compilation (decl, 1, 0);`	`rest_of_decl_compilation (decl, 1, 0);`
`}`	`}`


`/* Process the local variables of a BLOCK construct. */`	`/* Process the local variables of a BLOCK construct. */`

`void`	`void`
`gfc_process_block_locals (gfc_namespace* ns)`	`gfc_process_block_locals (gfc_namespace* ns)`
`{`	`{`
`tree decl;`	`tree decl;`

`gcc_assert (saved_local_decls == NULL_TREE);`	`gcc_assert (saved_local_decls == NULL_TREE);`
`generate_local_vars (ns);`	`generate_local_vars (ns);`

`decl = saved_local_decls;`	`decl = saved_local_decls;`
`while (decl)`	`while (decl)`
`{`	`{`
`tree next;`	`tree next;`

`next = TREE_CHAIN (decl);`	`next = TREE_CHAIN (decl);`
`TREE_CHAIN (decl) = NULL_TREE;`	`TREE_CHAIN (decl) = NULL_TREE;`
`pushdecl (decl);`	`pushdecl (decl);`
`decl = next;`	`decl = next;`
`}`	`}`
`saved_local_decls = NULL_TREE;`	`saved_local_decls = NULL_TREE;`
`}`	`}`


`#include "gt-fortran-trans-decl.h"`	`#include "gt-fortran-trans-decl.h"`

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.