/*Interface routines for the GNU Pascal runtime system.
  Copyright (C) 1987-2002 Free Software Foundation, Inc.

  Authors: Jukka Virtanen <jtv@hut.fi>
           Peter Gerwinski <peter@gerwinski.de>
           Frank Heckenbach <frank@pascal.gnu.de>

  This file is part of GNU Pascal.

  GNU Pascal 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 Software Foundation; either version 2, or (at your
  option) any later version.

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

  You should have received a copy of the GNU General Public License
  along with GNU Pascal; see the file COPYING. If not, write to the
  Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  02111-1307, USA. */

#include "gbe.h"

#include "gpc-defs.h"
#include "module.h"
#include "parse.h"
#include "types.h"
#include "util.h"
#include "rts/constants.h"
#include "rtscall.h"
#include "system.h"

/* Internal flag:  Nonzero means to accept components of packed
 * structured variables as variable parameters.
 */
int allow_packed_var_parameters = 0;

/* no params to function */
tree ptype_void;

/* single param rts calls */
tree ptype_int;
static tree ptype_pointer, ptype_longint, ptype_sizetype,
       ptype_char, ptype_bool, ptype_double, ptype_long_double,
       ptype_complex, ptype_string_schema,
       ptype_const_string_schema;

/* inline functions are not here */
struct rts_symbol rts[] =
{
  { r_WRITE,                  "_p_write",                 NULL_RTX, NULL_TREE, 1, 0 },
  { r_READ,                   "_p_read",                  NULL_RTX, NULL_TREE, 1, 0 },
  { r_INITFDR,                "_p_initfdr",               NULL_RTX, NULL_TREE, 0, 0 },
  { r_LAZYTRYGET,             "_p_lazytryget",            NULL_RTX, NULL_TREE, 1, 0 },
  { r_LAZYGET,                "_p_lazyget",               NULL_RTX, NULL_TREE, 1, 0 },
  { r_LAZYUNGET,              "_p_lazyunget",             NULL_RTX, NULL_TREE, 1, 0 },

  { p_ARCTAN,                 "_p_Real_ArcTan",           NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { p_COS,                    "_p_Real_Cos",              NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { p_EXP,                    "_p_Real_Exp",              NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { p_LN,                     "_p_Real_Ln",               NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { p_SIN,                    "_p_Real_Sin",              NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { p_SQRT,                   "_p_Real_SqRt",             NULL_RTX, NULL_TREE, 0, RTS_CONST },

  { pp_ARCTAN,                "_p_LongReal_ArcTan",       NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { pp_SIN,                   "_p_LongReal_Sin",          NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { pp_COS,                   "_p_LongReal_Cos",          NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { pp_EXP,                   "_p_LongReal_Exp",          NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { pp_LN,                    "_p_LongReal_Ln",           NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { pp_SQRT,                  "_p_LongReal_SqRt",         NULL_RTX, NULL_TREE, 0, RTS_CONST },

  { ucsd_INT,                 "_p_int",                   NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { bp_FRAC,                  "_p_frac",                  NULL_RTX, NULL_TREE, 0, RTS_CONST },

  { p_DISPOSE,                "_p_dispose",               NULL_RTX, NULL_TREE, 0, 0 },
  { p_EOF,                    "_p_eof",                   NULL_RTX, NULL_TREE, 1, 0 },
  { p_EOLN,                   "_p_eoln",                  NULL_RTX, NULL_TREE, 1, 0 },
  { bp_FREEMEM,               "_p_dispose",               NULL_RTX, NULL_TREE, 0, 0 },
  { p_GET,                    "_p_get",                   NULL_RTX, NULL_TREE, 1, 0 },
  { bp_GETMEM,                "_p_new",                   NULL_RTX, NULL_TREE, 0, 0 },
  { p_NEW,                    "_p_new",                   NULL_RTX, NULL_TREE, 0, 0 },
  { p_PAGE,                   "_p_page",                  NULL_RTX, NULL_TREE, 1, 0 },
  { p_PUT,                    "_p_put",                   NULL_RTX, NULL_TREE, 1, 0 },
  { p_RESET,                  "_p_reset",                 NULL_RTX, NULL_TREE, 1, 0 },
  { p_REWRITE,                "_p_rewrite",               NULL_RTX, NULL_TREE, 1, 0 },
  { p_MARK,                   "_p_mark",                  NULL_RTX, NULL_TREE, 0, 0 },
  { p_RELEASE,                "_p_release",               NULL_RTX, NULL_TREE, 0, 0 },
  { p_CLOSE,                  "_p_close",                 NULL_RTX, NULL_TREE, 1, 0 },
  { p_DONEFDR,                "_p_donefdr",               NULL_RTX, NULL_TREE, 1, 0 },
  { r_POW,                    "_p_Real_Pow",              NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { r_EXPON,                  "_p_Real_Power",            NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { rr_POW,                   "_p_LongReal_Pow",          NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { rr_EXPON,                 "_p_LongReal_Power",        NULL_RTX, NULL_TREE, 0, RTS_CONST },

  /* Extended Pascal libcalls. */

  /* Functions with COMPLEX_TYPE parameters */
  /* @@ Note: Don't use RTS_CONST for the complex functions. It has no effect
        on some platforms (e.g., Linux/IA32), and fails completely (i.e.,
        functions are not called) on others (e.g., IRIX/MIPS, maur8.pas). */
  { z_ABS,                    "_p_z_abs",                 NULL_RTX, NULL_TREE, 0, 0 },
  { z_ARCTAN,                 "_p_z_arctan",              NULL_RTX, NULL_TREE, 0, 0 },
  { z_COS,                    "_p_z_cos",                 NULL_RTX, NULL_TREE, 0, 0 },
  { z_EXP,                    "_p_z_exp",                 NULL_RTX, NULL_TREE, 0, 0 },
  { z_LN,                     "_p_z_ln",                  NULL_RTX, NULL_TREE, 0, 0 },
  { z_SIN,                    "_p_z_sin",                 NULL_RTX, NULL_TREE, 0, 0 },
  { z_SQRT,                   "_p_z_sqrt",                NULL_RTX, NULL_TREE, 0, 0 },
  { z_POW,                    "_p_z_pow",                 NULL_RTX, NULL_TREE, 0, 0 },
  { z_EXPON,                  "_p_z_expon",               NULL_RTX, NULL_TREE, 0, 0 },
  { p_POLAR,                  "_p_polar",                 NULL_RTX, NULL_TREE, 0, 0 },
  { p_ARG,                    "_p_arg",                   NULL_RTX, NULL_TREE, 0, 0 },

  { p_GETTIMESTAMP,           "_p_gettimestamp",          NULL_RTX, NULL_TREE, 0, 0 },
  { p_DATE,                   "_p_date",                  NULL_RTX, NULL_TREE, 0, 0 },
  { p_TIME,                   "_p_time",                  NULL_RTX, NULL_TREE, 0, 0 },
  { p_HALT,                   "_p_halt",                  NULL_RTX, NULL_TREE, 0, RTS_NORETURN },

  { p_EMPTY,                  "_p_empty",                 NULL_RTX, NULL_TREE, 1, 0 },
  { p_EXTEND,                 "_p_extend",                NULL_RTX, NULL_TREE, 1, 0 },
  { p_UPDATE,                 "_p_update",                NULL_RTX, NULL_TREE, 1, 0 },
  { p_POSITION,               "_p_position",              NULL_RTX, NULL_TREE, 1, 0 },
  { p_LASTPOSITION,           "_p_lastposition",          NULL_RTX, NULL_TREE, 1, 0 },
  { ucsd_SEEK,                "_p_seekall",               NULL_RTX, NULL_TREE, 1, 0 },
  { p_SEEKWRITE,              "_p_seekwrite",             NULL_RTX, NULL_TREE, 1, 0 },
  { p_SEEKREAD,               "_p_seekread",              NULL_RTX, NULL_TREE, 1, 0 },
  { p_SEEKUPDATE,             "_p_seekupdate",            NULL_RTX, NULL_TREE, 1, 0 },

  /* String functions. */
  { p_INDEX,                  "_p_index",                 NULL_RTX, NULL_TREE, 0, 0 },  /* reserved word */
  { p_SUBSTR,                 "_p_substr",                NULL_RTX, NULL_TREE, 0, 0 },
  { p_TRIM,                   "_p_trim",                  NULL_RTX, NULL_TREE, 0, 0 },
  /* Lexicographic string comparisons. */
  { p_EQ,                     "_p_eq",                    NULL_RTX, NULL_TREE, 0, 0 },
  { p_NE,                     "_p_eq",                    NULL_RTX, NULL_TREE, 0, 0 },
  { p_LT,                     "_p_lt",                    NULL_RTX, NULL_TREE, 0, 0 },
  { p_GT,                     "_p_lt",                    NULL_RTX, NULL_TREE, 0, 0 },
  { p_LE,                     "_p_lt",                    NULL_RTX, NULL_TREE, 0, 0 },
  { p_GE,                     "_p_lt",                    NULL_RTX, NULL_TREE, 0, 0 },
  /* String comparisons with space padding. */
  { '=',                      "_p_str_eq",                NULL_RTX, NULL_TREE, 0, 0 },
  { LEX_NE,                   "_p_str_eq",                NULL_RTX, NULL_TREE, 0, 0 },
  { '<',                      "_p_str_lt",                NULL_RTX, NULL_TREE, 0, 0 },
  { LEX_LE,                   "_p_str_lt",                NULL_RTX, NULL_TREE, 0, 0 },
  { '>',                      "_p_str_lt",                NULL_RTX, NULL_TREE, 0, 0 },
  { LEX_GE,                   "_p_str_lt",                NULL_RTX, NULL_TREE, 0, 0 },

  /* Read from string, write to string. */
  { p_READSTR,                "_p_readstr",               NULL_RTX, NULL_TREE, 0, 0 },
  { p_WRITESTR,               "_p_writestr",              NULL_RTX, NULL_TREE, 0, 0 },
  { ucsd_STR,                 "_p_writestr",              NULL_RTX, NULL_TREE, 0, 0 },
  { gpc_FORMATSTRING,         "_p_FormatString",          NULL_RTX, NULL_TREE, 0, 0 },

  /* BP's `Val' are *many* RTS functions. */
  { bp_VAL_byteint_check,     "_p_val_byteint_check",     NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_shortint_check,    "_p_val_shortint_check",    NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_integer_check,     "_p_val_integer_check",     NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_medint_check,      "_p_val_medint_check",      NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_longint_check,     "_p_val_longint_check",     NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_bytecard_check,    "_p_val_bytecard_check",    NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_shortcard_check,   "_p_val_shortcard_check",   NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_cardinal_check,    "_p_val_cardinal_check",    NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_medcard_check,     "_p_val_medcard_check",     NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_longcard_check,    "_p_val_longcard_check",    NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_byteint_nocheck,   "_p_val_byteint_nocheck",   NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_shortint_nocheck,  "_p_val_shortint_nocheck",  NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_integer_nocheck,   "_p_val_integer_nocheck",   NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_medint_nocheck,    "_p_val_medint_nocheck",    NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_longint_nocheck,   "_p_val_longint_nocheck",   NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_bytecard_nocheck,  "_p_val_bytecard_nocheck",  NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_shortcard_nocheck, "_p_val_shortcard_nocheck", NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_cardinal_nocheck,  "_p_val_cardinal_nocheck",  NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_medcard_nocheck,   "_p_val_medcard_nocheck",   NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_longcard_nocheck,  "_p_val_longcard_nocheck",  NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_shortreal,         "_p_val_shortreal",         NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_real,              "_p_val_real",              NULL_RTX, NULL_TREE, 0, 0 },
  { bp_VAL_longreal,          "_p_val_longreal",          NULL_RTX, NULL_TREE, 0, 0 },

  /* Set operations */
  { set_card,                 "_p_set_card",              NULL_RTX, NULL_TREE, 0, 0 },
  { set_isempty,              "_p_set_isempty",           NULL_RTX, NULL_TREE, 0, 0 },
  { set_equal,                "_p_set_equal",             NULL_RTX, NULL_TREE, 0, 0 },
  { set_le,                   "_p_set_le",                NULL_RTX, NULL_TREE, 0, 0 },
  { set_less,                 "_p_set_less",              NULL_RTX, NULL_TREE, 0, 0 },
  { set_in,                   "_p_set_in",                NULL_RTX, NULL_TREE, 0, 0 },
  { set_clear,                "_p_set_clear",             NULL_RTX, NULL_TREE, 0, 0 },
  { set_include,              "_p_set_include",           NULL_RTX, NULL_TREE, 0, 0 },
  { set_exclude,              "_p_set_execlude",          NULL_RTX, NULL_TREE, 0, 0 },
  { set_include_range,        "_p_set_include_range",     NULL_RTX, NULL_TREE, 0, 0 },
  { set_copy,                 "_p_set_copy",              NULL_RTX, NULL_TREE, 0, 0 },
  { set_intersection,         "_p_set_intersection",      NULL_RTX, NULL_TREE, 0, 0 },
  { set_union,                "_p_set_union",             NULL_RTX, NULL_TREE, 0, 0 },
  { set_diff,                 "_p_set_diff",              NULL_RTX, NULL_TREE, 0, 0 },
  { set_symdiff,              "_p_set_symdiff",           NULL_RTX, NULL_TREE, 0, 0 },

  /* Binding routines */
  { p_BIND,                   "_p_bind",                  NULL_RTX, NULL_TREE, 1, 0 },
  { p_BINDING,                "_p_binding",               NULL_RTX, NULL_TREE, 0, 0 },
  { p_UNBIND,                 "_p_unbind",                NULL_RTX, NULL_TREE, 1, 0 },

  /* UCSD/BP extensions */
  { ucsd_FILLCHAR,            "memset",                   NULL_RTX, NULL_TREE, 0, 0 },
  { bp_MOVE,                  "_p_move",                  NULL_RTX, NULL_TREE, 0, 0 },
  { ucsd_MOVELEFT,            "_p_moveleft",              NULL_RTX, NULL_TREE, 0, 0 },
  { ucsd_MOVERIGHT,           "_p_moveright",             NULL_RTX, NULL_TREE, 0, 0 },
  { ucsd_BLOCKREAD,           "_p_blockread",             NULL_RTX, NULL_TREE, 1, 0 },
  { ucsd_BLOCKWRITE,          "_p_blockwrite",            NULL_RTX, NULL_TREE, 1, 0 },
  { bp_ASSIGN,                "_p_assign",                NULL_RTX, NULL_TREE, 1, 0 },
  { bp_APPEND,                "_p_extend",                NULL_RTX, NULL_TREE, 1, 0 },  /* Just a synonym */
  { bp_FILEPOS,               "_p_position",              NULL_RTX, NULL_TREE, 1, 0 },  /* Just a synonym */
  { bp_FILESIZE,              "_p_getsize",               NULL_RTX, NULL_TREE, 1, 0 },  /* Just a synonym */
  { bp_TRUNCATE,              "_p_truncate",              NULL_RTX, NULL_TREE, 1, 0 },
  { bp_FLUSH,                 "_p_flush",                 NULL_RTX, NULL_TREE, 1, 0 },
  { bp_ERASE,                 "_p_erase",                 NULL_RTX, NULL_TREE, 1, 0 },
  { bp_RENAME,                "_p_rename",                NULL_RTX, NULL_TREE, 1, 0 },
  { bp_CHDIR,                 "_p_chdir",                 NULL_RTX, NULL_TREE, 1, 0 },
  { bp_MKDIR,                 "_p_mkdir",                 NULL_RTX, NULL_TREE, 1, 0 },
  { bp_RMDIR,                 "_p_rmdir",                 NULL_RTX, NULL_TREE, 1, 0 },
  { bp_RUNERROR,              "_p_runerror",              NULL_RTX, NULL_TREE, 0, RTS_NORETURN },
  { ucsd_INSERT,              "_p_insert",                NULL_RTX, NULL_TREE, 0, 0 },
  { ucsd_DELETE,              "_p_delete",                NULL_RTX, NULL_TREE, 0, 0 },
  { ucsd_POS,                 "_p_index",                 NULL_RTX, NULL_TREE, 0, 0 },
  { ucsd_COPY,                "_p_substr",                NULL_RTX, NULL_TREE, 0, 0 },
  { ucsd_IORESULT,            "_p_ioresult",              NULL_RTX, NULL_TREE, 0, 0 },
  { gpc_UPCASE,               "_p_LocaleUpCase",          NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { bp_UPCASE,                "_p_BP_UpCase",             NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { bp_INCLUDE,               "_p_set_include",           NULL_RTX, NULL_TREE, 0, 0 },
  { bp_EXCLUDE,               "_p_set_exclude",           NULL_RTX, NULL_TREE, 0, 0 },
  { bp_RANDOM,                "_p_randint",               NULL_RTX, NULL_TREE, 0, 0 },
  { bp_RANDREAL,              "_p_randreal",              NULL_RTX, NULL_TREE, 0, 0 },
  { bp_RANDOMIZE,             "_p_randomize",             NULL_RTX, NULL_TREE, 0, 0 },

  /* GPC extensions.  Pax used to have `DefineSize'. */
  { p_DEFINESIZE,             "_p_definesize",            NULL_RTX, NULL_TREE, 1, 0 },
  { gpc_LOCASE,               "_p_LocaleLoCase",          NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { gpc_SETFILETIME,          "_p_set_file_time",         NULL_RTX, NULL_TREE, 1, 0 },
  { gpc_NEWCSTRING,           "_p_newcstring",            NULL_RTX, NULL_TREE, 0, 0 },
  { gpc_CSTRINGCOPYSTRING,    "_p_cstringcopystring",     NULL_RTX, NULL_TREE, 0, 0 },
  { gpc_CSTRING2STRING,       "_p_copycstring",           NULL_RTX, NULL_TREE, 0, 0 },
  { LEX_IS,                   "_p_ObjectTypeIs",          NULL_RTX, NULL_TREE, 0, RTS_CONST },
  { LEX_AS,                   "_p_ObjectTypeAsError",     NULL_RTX, NULL_TREE, 0, RTS_NORETURN },

  /* Internal functions */
  { gpc_IOCHECK,              "_p_check_inoutres",        NULL_RTX, NULL_TREE, 0, 0 },
  { gpc_RUNTIME_ERROR,        "_p_error",                 NULL_RTX, NULL_TREE, 0, RTS_NORETURN },

  { 0,                        NULL,                       NULL_RTX, NULL_TREE, 0, 0 }
};

/* Declare functions with prototypes. */

static int get_read_flags PARAMS ((void));
static tree save_expr_string PARAMS ((tree));
static void rts_read PARAMS ((int, tree));
static tree rts_write PARAMS ((int, tree));
static void rts_val PARAMS ((tree));
static tree pascal_unpack_and_pack PARAMS ((int, tree, tree, tree));
static tree check_argument PARAMS ((tree, char *, int, char **, tree *, enum tree_code *));

/* Some RTS function formal parameters are constructed by this routine. */
tree
do_ptype (type, var, last)
     tree type;
     int var;  /* 0: use type; 1: build_reference; 2: build_pointer */
     int last;
{
  tree temp;

  if (var == 1)
    type = build_reference_type (type);
  else if (var == 2)
    type = build_pointer_type (type);

  temp = build_tree_list (NULL_TREE, type);

  /* True if this is the last parameter to the function */
  if (last)
    temp = chainon (temp, ptype_void);

  return temp;
}

/* Declares some useful RTS call types */
void
declare_rts_types ()
{
  ptype_void = build_tree_list (NULL_TREE, void_type_node);
  ptype_pointer = do_ptype (ptr_type_node, 0, 1);
  ptype_int = do_ptype (integer_type_node, 0, 1);
  ptype_longint = do_ptype (long_long_integer_type_node, 0, 1);
  ptype_sizetype = do_ptype (sizetype, 0, 1);
  ptype_char = do_ptype (char_type_node, 0, 1);
  ptype_bool = do_ptype (boolean_type_node, 0, 1);
  ptype_double = do_ptype (double_type_node, 0, 1);
  ptype_long_double = do_ptype (long_double_type_node, 0, 1);
  ptype_complex = do_ptype (complex_type_node, 0, 1);
  ptype_string_schema = do_ptype (string_schema_proto_type, 1, 1);
  ptype_const_string_schema = do_ptype (const_string_schema_proto_type, 1, 1);

  /* The following can't be variables (without the `chainon') since
   * their TREE_CHAIN fields would be overwritten, and they can
   * occur multiple times in one list.
   */
  #define chainon_int(X)                 chainon (do_ptype (integer_type_node, 0, 0), X)
  #define chainon_pointer(X)             chainon (do_ptype (ptr_type_node, 0, 0), X)
  #define chainon_pointer_const(X)       chainon (do_ptype (const_ptr_type_node, 0, 0), X)
  #define chainon_cstring(X)             chainon (do_ptype (cstring_type_node, 0, 0), X)
  #define chainon_double(X)              chainon (do_ptype (double_type_node, 0, 0), X)
  #define chainon_string_schema(X)       chainon (do_ptype (string_schema_proto_type, 1, 0), X)
  #define chainon_const_string_schema(X) chainon (do_ptype (const_string_schema_proto_type, 1, 0), X)
}

tree
ptype_set (constant, next_arg)
     int constant;
     tree next_arg;
{
  if (constant)
    return chainon_pointer_const (chainon_int (next_arg ? chainon_int (next_arg) : ptype_int));
  else
    return chainon_pointer (chainon_int (next_arg ? chainon_int (next_arg) : ptype_int));
}

tree
actual_set_parameters (val)
     tree val;
{
  tree addr;

  /* All callers should now handle the constant empty set themselves. */
  assert (TREE_CODE (TREE_TYPE (TREE_TYPE (val))) != VOID_TYPE);
  #if 0
  if (TREE_CODE (TREE_TYPE (TREE_TYPE (val))) == VOID_TYPE);
    /* Empty set. Pass nil pointer, and low > high */
    return chainon (build_tree_list (NULL_TREE, null_pointer_node),
           chainon (build_tree_list (NULL_TREE, integer_maxint_node),
                    build_tree_list (NULL_TREE, integer_zero_node)));
  #endif

  assert (mark_addressable (val));
  #if 0
  /* Previously, such code was here (or rather, in build_pascal_binary_op).
     But assign_set calls `set_copy' which passes the arguments just like
     the other set routines, so we don't win anything. So I conclude that
     this case must not occur. :-) -- Frank */
  if (!mark_addressable (val))
    {
      tree temp1 = make_new_variable ("set_operand", TREE_TYPE (val));
      val = build (COMPOUND_EXPR, TREE_TYPE (temp), assign_set (temp1, val), temp1);
    }
  #endif

  /* Functions returning sets are no lvalues, so build_pascal_unary_op
     would complain. So call build1 directly. For other cases, let
     build_pascal_unary_op do its various checks. -- @@Maybe it would
     be better to make the formal parameters to the set operations
     (apart from the bounds) arrays instead of pointers (if this is
     possible, and doesn't cause unnecessary copying!?), so we won't
     need any special code here. -- Frank */
  if (TREE_CODE (val) == CALL_EXPR)
    addr = build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (val)), val);
  else
    addr = build_pascal_unary_op (ADDR_EXPR, val, 0);

  return chainon (build_tree_list (NULL_TREE, addr),
         chainon (build_tree_list (NULL_TREE,
                    convert (integer_type_node, TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (val))))),
                  build_tree_list (NULL_TREE,
                    convert (integer_type_node, TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (val)))))));
}

/* RTS_ID: What routine we are calling
 * VALUE_TYPE: return value from calling NAME
 * FORMAL_PARAMS: List of formal parameters; NULL_TREE is not allowed.
 * PARAMS: a list -- a chain of TREE_LIST nodes -- in which the
 *         TREE_VALUE of each node is a parameter-expression.
 */
tree
rts_call (rts_id, value_type, formal_params, params)
     int rts_id;
     tree value_type;
     tree formal_params;
     tree params;
{
  int index, rts_routine_found;
  tree fun, result;

  assert (formal_params != NULL);

  for (index = 0; (rts_routine_found = rts[index].val) != rts_id; index++)
    assert (rts_routine_found);

  fun = build_decl (FUNCTION_DECL,
                    get_identifier(rts[index].name),
                    build_function_type (value_type, formal_params));

  DECL_EXTERNAL (fun) = 1;
  TREE_PUBLIC (fun) = 1;

  DECL_SOURCE_FILE (fun) = "Pascal Run Time System";
  DECL_SOURCE_LINE (fun) = 1;

  /* Add `noreturn' or `const' attribute if appropriate. */
  if (rts[index].attribute == RTS_NORETURN)
    TREE_THIS_VOLATILE (fun) = 1;
  else if (rts[index].attribute == RTS_CONST)
    TREE_READONLY (fun) = 1;

  rest_of_decl_compilation (fun, NULL_PTR, 0, 0);

  /* @@@ Can't reuse the fun later because the argument types
   * may vary in each call (i.e. the _p_new takes any pointer)
   *
   * Should check if could use `void *' et. al. for these cases ...
   *
   * -- Might consider whether is worthwhile if use subject in sentence ...
   *
   * This must certainly be possible, since all the RTS routines
   * are declared as regular C or Pascal routines. The declarations
   * are readily available in the rts directory. -- Frank
   */
  if (!rts[index].fun && ! flag_syntax_only)
    {
      assert (rts[index].symref);

      /* If this machine requires an external definition for library
       * functions, write one out.
       *
       * HP-UX .import FOO directives are done here.
       * I don't think this needs to be called but once per routine.
       */
      assemble_external_libcall (rts[index].symref);
      rts[index].fun = fun;
    }

  allow_packed_var_parameters++;
  result = build_function_call (fun, params);
  allow_packed_var_parameters--;
  if (flag_io_checking && rts[index].io_critical)
    {
      tree iocheck = build (COND_EXPR, integer_type_node,
                            build_pascal_binary_op (NE_EXPR,
                              get_builtin_variable ("_p_InOutRes", integer_type_node),
                              integer_zero_node),
                            rts_call (gpc_IOCHECK, void_type_node, ptype_void, NULL_TREE),
                            integer_zero_node);
      if (TREE_CODE (TREE_TYPE (result)) == VOID_TYPE || TREE_TYPE (result) == error_mark_node)
        result = build1 (CONVERT_EXPR, void_type_node,
                         build (COMPOUND_EXPR, integer_type_node, result, iocheck));
      else
        {
          /* @@ Can we do it somehow without the temp var? We'd need something
                like a "left-valued comma", i.e. evaluate first a, then b, and
                return a. -- Frank */
          tree temp_var = make_new_variable ("save_across_io_check", TREE_TYPE (result));
          TREE_USED (temp_var) = 1;
          result = build (COMPOUND_EXPR, TREE_TYPE (temp_var),
                     build (COMPOUND_EXPR, integer_type_node,
                            build_modify_expr (temp_var, NOP_EXPR, result),
                            iocheck),
                     temp_var);
        }
    }
  return result;
}

static int
get_read_flags ()
{
  int flags = 0;
  if (flag_read_base_specifier)
    flags |= INT_READ_BASE_SPEC_MASK;
  if (flag_read_hex)
    flags |= INT_READ_HEX_MASK;
  if (flag_read_white_space)
    flags |= NUM_READ_CHK_WHITE_MASK;
  if ((flag_what_pascal & CLASSIC_PASCAL) != 0
      && (flag_what_pascal & ~CLASSIC_PASCAL) == 0)
    flags |= REAL_READ_SP_ONLY_MASK;
  /*@@@@@ INT_READ_CHECK_MASK was removed (19981223). Now, the
          `check' parameter to _p_readi() has to be used instead
  if (flag_input_range_checking)  * note: not implemented yet *
    flags |= INT_READ_CHECK_MASK; */
  return flags;
}

/* @@ Kludge. When `ReadStr' and `Val' in the RTS are rewritten in Pascal,
      they can take proper `const String' parameters, and this should be
      unneeded. (note `function: PString' vs. `function: String') -- Frank */
static tree
save_expr_string (string)
     tree string;
{
  tree t, stmts = NULL_TREE;
#if 0
  if (TREE_CODE (TREE_TYPE (string)) == CHAR_TYPE)
    string = new_string_by_model (NULL_TREE, string, 1);
#endif

  /* Non string schemata don't need to be saved, because `ReadStr' and `Val'
     will access them only once, anyway (not for the length). */
  if (!PASCAL_TYPE_STRING (TREE_TYPE (string)))
    return string;

  t = string;
  while (1)
    if (TREE_CODE (t) == NOP_EXPR
        || TREE_CODE (t) == CONVERT_EXPR
        || TREE_CODE (t) == NON_LVALUE_EXPR
        || TREE_CODE (t) == SAVE_EXPR)
      t = TREE_OPERAND (t, 0);
    else if (TREE_CODE (t) == COMPOUND_EXPR)
      {
        if (stmts)
          stmts = build (COMPOUND_EXPR, void_type_node,
                         TREE_OPERAND (t, 0), stmts);
        else
          stmts = TREE_OPERAND (t, 0);
        t = TREE_OPERAND (t, 1);
      }
    else
      break;
  if (TREE_CODE (t) == INDIRECT_REF)
    string = build_indirect_ref (save_expr (TREE_OPERAND (t, 0)), "ReadStr/Val");
  else if (TREE_CODE (t) != VAR_DECL)  /* calling `function: String' creates a temp var decl */
    string = build_indirect_ref (save_expr (build_unary_op (ADDR_EXPR, string, 0)), "ReadStr/Val");
  if (stmts)
    string = build (COMPOUND_EXPR, TREE_TYPE (string), stmts, string);
  return string;
}

/* Read from files and strings. */
static void
rts_read (rts_id, params)
     int rts_id;
     tree params;
{
  tree parm;
  int length;
  tree arglist = NULL_TREE;
  tree fpar;
  tree string_curlen = NULL_TREE;
  tree string_length = NULL_TREE;

  if (rts_id == p_READSTR)
    {
      tree string, string_length;

      if (! params
          || ! (is_string_compatible_type (TREE_VALUE (params), 1)
                || ((flag_extended_syntax || (flag_what_pascal & B_D_PASCAL))
                    && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_VALUE (params)))
                       == cstring_type_node)))
        {
          error ("argument 1 to `ReadStr' must be the string to read from");
          if (! flag_extended_syntax
              && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_VALUE (params)))
                 == cstring_type_node)
            cstring_inform ();
          return;
        }

      /* Find out the number of args we are reading.
       * @@@ ??? This does not work if it is done
       * after `params = TREE_CHAIN (params)'. :-(
       */
      length = list_length (params) - 1;

      string = TREE_VALUE (params);
      params = TREE_CHAIN (params);

      if (TYPE_MAIN_VARIANT (TREE_TYPE (string)) == cstring_type_node)
        string_length = build_int_2 (-1, -1);
      else
        {
          string = save_expr_string (string);
          string_length = PASCAL_STRING_LENGTH (string);
          string = build1 (ADDR_EXPR, ptr_type_node, PASCAL_STRING_VALUE (string));
        }

      /* First three args:
       *  string pointer, current length, number of args
       *
       * Note that the string does not need to be an lvalue.
       */
      arglist = tree_cons (NULL_TREE, string, tree_cons (NULL_TREE, string_length, NULL_TREE));
      fpar = chainon_pointer (chainon_int (chainon_int (do_ptype (integer_type_node, 0, 0))));
    }
  else
    {
      tree file;
      int is_text;

      if (params
          && TREE_CODE (TREE_TYPE (TREE_VALUE (params))) == FILE_TYPE)
        {
          file = TREE_VALUE (params);
          params = TREE_CHAIN (params);
        }
      else
        file = get_standard_input ();

      if (rts_id == p_READ && ! params)
        {
          if ((flag_what_pascal & B_D_PASCAL) == 0)
            pedwarn ("`Read' without variables to read - ignored");
          return;
        }

      is_text = TYPE_FILE_TEXT (TREE_TYPE (file));

      if (rts_id == p_READLN)
        if (! is_text)
          {
            error ("`ReadLn' is allowed only when reading from files of type `Text'");
            return;
          }

      if (rts_id == p_READ)
        {
          if (params == NULL_TREE)
            {
              error ("too few arguments to predefined procedure `Read'");
              return;
            }

          /* Non TEXT file reads */
          if (! is_text)
            {
              for (parm = params; parm; parm = TREE_CHAIN (parm))
                {
                  /* Call build_buffer_ref *within* the loop so the lazy getting is done each time */
                  expand_expr_stmt (build_modify_expr (TREE_VALUE (parm),
                                                       NOP_EXPR,
                                                       build_buffer_ref (file, r_LAZYGET)));
                  build_rts_call (p_GET, build_tree_list (NULL_TREE, file));
                }
              return;
            }
        }
      /* find out the number of args we are reading */
      length = list_length (params);
      length += rts_id == p_READLN;   /* add P_LINE */

      allow_packed_var_parameters++;
      arglist = tree_cons (NULL_TREE, file, NULL_TREE);
      allow_packed_var_parameters--;
      fpar = chainon (do_ptype (TREE_TYPE (file), 1, 0), chainon_int (do_ptype (integer_type_node, 0, 0)));
    }

  arglist = chainon (arglist, build_tree_list (NULL_TREE, build_int_2 (get_read_flags (), 0)));
  arglist = chainon (arglist, build_tree_list (NULL_TREE, build_int_2 (length, 0)));

  for (parm = params; parm; parm = TREE_CHAIN (parm))
    {
      tree p = TREE_VALUE (parm);
      enum tree_code code = TREE_CODE (TREE_TYPE (p));
      int what;

      length--;
      switch (code)
        {
          case INTEGER_TYPE:
            {
              /* Handle all integer types. */
              if (! TREE_UNSIGNED (TREE_TYPE (p)))
                {
                  int prec = TYPE_PRECISION (TREE_TYPE (p));
                  if (prec > TYPE_PRECISION (long_integer_type_node))
                    what = P_S_LONGLONG;
                  else if (prec > TYPE_PRECISION (integer_type_node))
                    what = P_S_LONG;
                  else if (prec > TYPE_PRECISION (short_integer_type_node))
                    what = P_S_INT;
                  else if (prec > TYPE_PRECISION (signed_char_type_node))
                    what = P_S_SHORT;
                  else
                    what = P_S_BYTE;
                }
              else
                {
                  int prec = TYPE_PRECISION (TREE_TYPE (p));
                  if (prec > TYPE_PRECISION (long_unsigned_type_node))
                    what = P_U_LONGLONG;
                  else if (prec > TYPE_PRECISION (unsigned_type_node))
                    what = P_U_LONG;
                  else if (prec > TYPE_PRECISION (short_unsigned_type_node))
                    what = P_U_INT;
                  else if (prec > TYPE_PRECISION (unsigned_char_type_node))
                    what = P_U_SHORT;
                  else
                    what = P_U_BYTE;
                }
              break;
            }
          case CHAR_TYPE :
            what = P_CHAR;
            break;
          case REAL_TYPE :
            /* Handle all real types. */
            {
              int prec = TYPE_PRECISION (TREE_TYPE (p));
              if (prec == TYPE_PRECISION (double_type_node))
                what = P_REAL;
              else if (prec == TYPE_PRECISION (float_type_node))
                what = P_SHORT_REAL;
              else if (prec == TYPE_PRECISION (long_double_type_node))
                what = P_LONG_REAL;
              else
                {
                  error ("unknown real type to read");
                  return;
                }
              break;
            }
          break;

          case RECORD_TYPE: /* String schema. */
          case ARRAY_TYPE:  /* Fixed length string. */
            switch (is_string_type (p, 1))
              {
                case 0:
                  error ("only packed arrays of char may be read from `Text' files");
                  continue;
                case 1:
                  break;
                case 2:
                  /* @@@ Should generate a runtime check for conformant arrays
                   * (low index has to be 1 for arrays to be valid string-type).
                   *
                   * For now, just read them.
                   */
                  break;
                default:
                  assert (0);
              }

            if (PEDANTIC (E_O_B_D_PASCAL))
              error ("ISO 7185 Pascal does not allow reading strings from textfiles");

            if (is_variable_string_type (TREE_TYPE (p)))
              {
                what = P_STRING;

                /* The RTS expects another argument before Capacity: a pointer
                 * to int where it stores the current length of the string.
                 * This needs to be an lvalue.
                 */
                string_curlen = build_unary_op (ADDR_EXPR, PASCAL_STRING_LENGTH (p), 0);

                /* String max length. */
                string_length = PASCAL_STRING_CAPACITY (p);
              }
            else
              {
                what = P_FIXED_STRING;

                /* String max length. */
                string_length = pascal_array_type_nelts (TREE_TYPE (PASCAL_STRING_VALUE (p)));
              }

            /* The char store. */
            p = PASCAL_STRING_VALUE (p);

            break;

          default:
            error ("argument to `Read'/`ReadLn' from `Text' file is of wrong type");
            /* FALLTHROUGH */

          case ERROR_MARK:
            return;
        }

      /* Inform the RTS of the next arg type. */
      arglist = chainon (arglist, build_tree_list (NULL_TREE, size_int (what)));

      /* Do not allow to read into read-only locations. */
      if (TREE_CODE (p) == COMPONENT_REF && PASCAL_TREE_DISCRIMINANT (TREE_OPERAND (p, 1)))
        error ("trying to read a schema discriminant");
      else if (TREE_CONSTANT (p) || TREE_READONLY (p))
        readonly_warning (p, "reading");
      else
        typed_const_warning (p);

      /* Pass the address of the variable we want to read.
       * According to ISO, packed fields are okay here
       * (but nowhere else when it comes to `var' parameters,
       * since the parameters of `Read' etc. are no normal `var'
       * parameters, anyway).
       */
      allow_packed_var_parameters++;
      if (is_packed_field (p))
        p = expand_packed_field (p, TREE_TYPE (p));
      arglist = chainon (arglist, build_tree_list (NULL_TREE, build_unary_op (ADDR_EXPR, p, 0)));
      allow_packed_var_parameters--;
      if (what == P_STRING)
        arglist = chainon (arglist, build_tree_list (NULL_TREE, string_curlen));

      if (what == P_STRING || what == P_FIXED_STRING)
        arglist = chainon (arglist, build_tree_list (NULL_TREE, string_length));

      /* Mark that we have assigned a value to this variable. */
      while (TREE_CODE (p) == COMPONENT_REF)
        p = TREE_OPERAND (p, 0);
      if (TREE_CODE (p) == VAR_DECL)
        PASCAL_VALUE_ASSIGNED (p) = 1;
    }

  if (rts_id == p_READLN)
    {
      /* Inform the RTS that we should do a ReadLn */
      arglist = chainon (arglist, build_tree_list (NULL_TREE, size_int (P_LINE)));
      length--;
    }

  assert (length == 0);

  expand_expr_stmt (rts_call ((rts_id == p_READSTR) ? p_READSTR : r_READ,
                              void_type_node, fpar, arglist));
}

/* Write to files and strings. */
static tree
rts_write (rts_id, params)
     int rts_id;
     tree params;
{
  tree parm;
  tree arglist;
  tree fpar;
  int length;

  int flags = 0;
  if (! flag_real_blank)
    flags |= REAL_NOBLANK_MASK;
  if (flag_capital_exponent)
    flags |= REAL_CAPITAL_EXP_MASK;
  if (flag_clip_strings)
    flags |= CLIP_STRING_MASK;
  if (flag_truncate_strings)
    flags |= TRUNCATE_STRING_MASK;

  if (rts_id == gpc_FORMATSTRING)
    {
      if (!is_string_compatible_type (TREE_VALUE (params), 1))
        {
          error ("argument 1 to FormatString must be a string or char");
          return error_mark_node;
        }
      arglist = build_tree_list (NULL_TREE, TREE_VALUE (params));
      fpar = do_ptype (const_string_schema_proto_type, 1, 0);
      params = TREE_CHAIN (params);
      length = list_length (params);
    }
  else if (rts_id == p_WRITESTR || rts_id == ucsd_STR)
    {
      tree string, string_pointer, tmp;
      int string_type = 0;

      if (rts_id == p_WRITESTR)
        {
          if (! params || ! is_string_type (TREE_VALUE (params), 1))
            {
              error ("argument 1 to `WriteStr' must be the string to write to");
              return NULL_TREE;
            }
          string = TREE_VALUE (params);
          params = TREE_CHAIN (params);
        }
      else
        {
          if (params)
            {
              tree p = params, q = NULL_TREE;
              while (TREE_CHAIN (p))
                {
                  q = p;
                  p = TREE_CHAIN (p);
                }
              string = p;
              if (q)
                TREE_CHAIN (q) = NULL_TREE;
              else
                {
                  error ("too few arguments to `Str'");
                  return NULL_TREE;
                }
            }
          else
            string = NULL_TREE;
          if (! string || ! is_string_type (TREE_VALUE (string), 1))
            {
              error ("last argument to `Str' must be the string to write to");
              return NULL_TREE;
            }
          string = TREE_VALUE (string);
        }

      /* Mark that we are assigning a value to the string variable. */
      tmp = string;
      while (TREE_CODE (tmp) == COMPONENT_REF)
        tmp = TREE_OPERAND (tmp, 0);
      if (TREE_CODE (tmp) == VAR_DECL)
        PASCAL_VALUE_ASSIGNED (tmp) = 1;

      /* Don't allow writes to a constant string. */
      if (really_constant_p (string) || TREE_READONLY (string))
        readonly_warning (string, rts_id == p_WRITESTR ? "`WriteStr': modification" : "`Str': modification");
      else
        typed_const_warning (string);

      /* Find out the number of args we are writing. */
      length = list_length (params);
      if (rts_id == ucsd_STR && length > 1 && (pedantic || flag_what_pascal))
        error ("multiple values in `Str' are a GNU Pascal extension");

      /* First four or five args: type of string, pointer to chars,
       * [pointer to current length], maximum length, number of values.
       * For fixed strings, no current length is passed.
       * The string needs to be an lvalue.
       */
      if (PASCAL_TYPE_STRING (TREE_TYPE (string)))
        {
          /* String schema. */
          string_type = P_STRING;
        }
      else if (TYPE_MAIN_VARIANT (base_type (TREE_TYPE (string))) == cstring_type_node)
        {
          /* CString. */
          string_type = P_CSTRING;
        }
      else if (TREE_CODE (TREE_TYPE (string)) == ARRAY_TYPE
               && TREE_CODE (TREE_TYPE (TREE_TYPE (string))) == CHAR_TYPE)
        {
          /* If this array is not packed, a warning about ISO
           * violation already has been given in the call to
           * is_string_type() above.
           */
          string_type = P_FIXED_STRING;
        }
      else
        /* It has already been checked that STRING is a string. */
        assert (0);

      allow_packed_var_parameters++;
      string_pointer = build_unary_op (ADDR_EXPR,
                                       PASCAL_STRING_VALUE (string), 0);
      allow_packed_var_parameters--;
      arglist = build_tree_list (NULL_TREE, build_int_2 (string_type, 0));
      arglist = chainon (arglist, build_tree_list (NULL_TREE, string_pointer));
      if (string_type == P_STRING)
        {
          tree curlen = build_unary_op (ADDR_EXPR,
                                        PASCAL_STRING_LENGTH (string), 0);
          arglist = chainon (arglist, build_tree_list (NULL_TREE, curlen));
          arglist = chainon (arglist, build_tree_list (NULL_TREE, PASCAL_STRING_CAPACITY (string)));
        }
      else
        arglist = chainon (arglist,
                           build_tree_list (NULL_TREE,
                             pascal_array_type_nelts (TREE_TYPE (
                                 PASCAL_STRING_VALUE (string)))));
      fpar = chainon_int (do_ptype (ptr_type_node, 0, 0));
    }
  else
    {
      tree file;
      int is_text;

      if (params
          && TREE_CODE (TREE_TYPE (TREE_VALUE (params))) == FILE_TYPE)
        {
          file = TREE_VALUE (params);
          params = TREE_CHAIN (params);
        }
      else
        file = get_standard_output ();

      is_text = TYPE_FILE_TEXT (TREE_TYPE (file));

      if (rts_id == p_WRITELN && ! is_text)
        {
          error ("`WriteLn' is allowed only when writing to files of type `Text'");
          return NULL_TREE;
        }

      if (rts_id == p_WRITE)
        {
          if (! params)
            {
              if ((flag_what_pascal & B_D_PASCAL) == 0)
                pedwarn ("`Write' without values to write - ignored");
              return NULL_TREE;
            }

          /* Non TEXT file writes. */
          if (! is_text)
            {
              tree the_file = build_tree_list (NULL_TREE, file);
              tree buffer = build_buffer_ref (file, r_LAZYUNGET);
              for (parm = params; parm; parm = TREE_CHAIN (parm))
                {
                  /* Check for strings being chars. */
                  TREE_VALUE (parm) = string_may_be_char (TREE_VALUE (parm));

                  /* Check whether the types match. */
                  if (comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (buffer)),
                                 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_VALUE (parm)))) == 0)
                    error ("incompatible types in `Write'");
                  else
                    {
                      /* Move the contents of the write parm to the file buffer. */
                      expand_assignment (buffer, TREE_VALUE (parm), 0, 0);

                      /* Do a put to the file. */
                      build_rts_call (p_PUT, the_file);
                    }
                }
              return NULL_TREE;
            }
        }
      /* find out the number of args we are writing */
      length = list_length (params);
      length += rts_id == p_WRITELN;  /* add P_LINE */

      allow_packed_var_parameters++;
      arglist = tree_cons (NULL_TREE, file, NULL_TREE);
      allow_packed_var_parameters--;
      fpar = chainon (do_ptype (TREE_TYPE (file), 1, 0), do_ptype (integer_type_node, 0, 0));
    }
  arglist = chainon (arglist, build_tree_list (NULL_TREE, build_int_2 (flags, 0)));
  arglist = chainon (arglist, build_tree_list (NULL_TREE, build_int_2 (length, 0)));

  for (parm = params; parm; parm = TREE_CHAIN (parm))
    {
      tree field1;
      tree field2;
      tree spurious_field2;

      int what;
      tree p = TREE_VALUE (parm);
      enum tree_code code;
      if (TREE_CODE (p) == STRING_CST && TREE_STRING_LENGTH (p) > 1)
        p = string_may_be_char (p);
      code = TREE_CODE (base_type (TREE_TYPE (p)));
      length--;
      if (TREE_PURPOSE (parm))
        {
          field1 = TREE_VALUE (TREE_PURPOSE (parm));
          field2 = TREE_PURPOSE (TREE_PURPOSE (parm));
        }
      else
        {
          field1 = NULL_TREE;
          field2 = NULL_TREE;
        }

      if (field1)
        field1 = convert (integer_type_node, field1);

      if (field2)
        field2 = convert (integer_type_node, field2);

      spurious_field2 = field2;

      if (rts_id == ucsd_STR
          && code != INTEGER_TYPE
          && code != REAL_TYPE
          && (pedantic || flag_what_pascal))
        error ("non-numeric values in `Str' are a GNU Pascal extension");

      switch (code)
        {
          case INTEGER_TYPE:
            if (!field2)
              {
                if (TREE_CODE (p) == INTEGER_CST)
                  {
                    if (int_fits_type_p (p, integer_type_node))
                      p = convert (integer_type_node, p);
                    else if (int_fits_type_p (p, unsigned_type_node))
                      p = convert (unsigned_type_node, p);
                  }

                /* Handle all integer types. */
                if (! TREE_UNSIGNED (TREE_TYPE (p)))
                  {
                    if (TYPE_PRECISION (TREE_TYPE (p)) >
                        TYPE_PRECISION (integer_type_node))
                      {
                        what = P_S_LONGLONG;
                        p = convert (long_long_integer_type_node, p);
                      }
                    else
                      {
                        what = P_S_INT;
                        p = convert (integer_type_node, p);
                      }
                  }
                else
                  {
                    if (TYPE_PRECISION (TREE_TYPE (p)) >
                        TYPE_PRECISION (unsigned_type_node))
                      {
                        what = P_U_LONGLONG;
                        p = convert (long_long_unsigned_type_node, p);
                      }
                    else
                      {
                        what = P_U_INT;
                        p = convert (unsigned_type_node, p);

                        /* @@@@@@@@@@ This is obviously wrong, but it works,
                           in contrast to not doing the following conversion
                           (which would be right). (fjf487*.pas)
                           Probably yet another strangeness of varargs. When
                           they're eliminated, maybe this problem will also
                           disappear ... -- Frank */
                        p = convert (integer_type_node, p);
                      }
                  }

                if (field1)
                  what |= FIX_WIDTH_MASK;
                else if ((what & ~FIX_WIDTH_MASK) == P_S_LONGLONG
                         || (what & ~FIX_WIDTH_MASK) == P_U_LONGLONG)
                  {
                    if (long_int_out_width)
                      {
                        field1 = build_int_2 (long_int_out_width, 0);
                        what |= FIX_WIDTH_MASK;
                      }
                  }
                else
                  {
                    if (int_out_width)
                      {
                        field1 = build_int_2 (int_out_width, 0);
                        what |= FIX_WIDTH_MASK;
                      }
                  }
                break;
              }
            else
              {
                /* Writing an integer with 2 widths -> convert to real type */
                p = convert (long_double_type_node, p);
                code = REAL_TYPE;
              }
              /* FALLTHROUGH */
          case REAL_TYPE :
          {
            /* Handle also LongReals. */
            int long_real_flag = TYPE_MAIN_VARIANT (TREE_TYPE (p)) == long_double_type_node
                                 || TYPE_PRECISION (TREE_TYPE (p)) > TYPE_PRECISION (double_type_node);
            what = P_LONG_REAL;
            spurious_field2 = NULL_TREE;
            p = convert (long_double_type_node, p);
            if (field1)
              {
                what |= FIX_WIDTH_MASK;
                if (field2)
                  what |= FIX2_REAL_MASK;
              }
            else if (long_real_flag)
              {
                if (long_real_out_width)
                  {
                    field1 = build_int_2 (long_real_out_width, 0);
                    what |= FIX_WIDTH_MASK;
                  }
              }
            else
              {
                if (real_out_width)
                  {
                    field1 = build_int_2 (real_out_width, 0);
                    what |= FIX_WIDTH_MASK;
                  }
              }
            break;
          }

          case BOOLEAN_TYPE:
            if (field1)
              what = P_BOOL | FIX_WIDTH_MASK;
            else if (bool_out_width)
              {
                field1 = build_int_2 (bool_out_width, 0);
                what = P_BOOL | FIX_WIDTH_MASK;
              }
            else
              what = P_BOOL;
            /* For va_arg: pass everything smaller than `int' as `int'. */
            p = convert (integer_type_node, p);
            break;

          case CHAR_TYPE:
            if (field1)
              what = P_CHAR | FIX_WIDTH_MASK;
            else
              what = P_CHAR;
            /* For va_arg: pass everything smaller than `int' as `int'. */
            p = convert (integer_type_node, p);
            break;

          case RECORD_TYPE:
          case ARRAY_TYPE:
            switch (is_string_type (p, 1))
              {
                case 0:
                  error ("only packed arrays of char with low index 1 may be");
                  error (" written to text files");
                  continue;
                case 1:
                  break;
                case 2:
                  /* @@@ Should generate a runtime check for conformant arrays.
                   * (Low index has to be 1 for arrays to be valid string-type).
                   * For now, just write them out.
                   * Note that the field1 below will be incorrect if confarrays
                   * don't start from 1.
                   */
                  break;
                default:
                  assert (0);
              }

            what = field1 ? P_ANY_STRING | FIX_WIDTH_MASK : P_ANY_STRING;
            field2 = field1;
            field1 = convert (integer_type_node, PASCAL_STRING_LENGTH (p));
            p = PASCAL_STRING_VALUE (p);

            /* pass the address of the string */
            p = build1 (ADDR_EXPR, string_type_node, p);
            break;

          case POINTER_TYPE:
            if (TYPE_MAIN_VARIANT (base_type (TREE_TYPE (p))) == cstring_type_node)
              {
                if (flag_extended_syntax || (flag_what_pascal & B_D_PASCAL))
                  {
                    what = field1 ? P_ANY_STRING | FIX_WIDTH_MASK : P_ANY_STRING;
                    field2 = field1;
                    field1 = build_int_2 (-1, -1);
                    break;
                  }
                else
                  {
                    error ("argument to `Write'/`WriteLn' to `Text' file is of wrong type");
                    cstring_inform ();
                    return NULL_TREE;
                  }
              }

          default:
            error ("argument to `Write'/`WriteLn' to `Text' file is of wrong type");
            /* FALLTHROUGH */

          case ERROR_MARK:
            return NULL_TREE;
        }
      if (spurious_field2)
        warning ("second field width allowed only when writing values of `Real' type");

      /* Inform the RTS of the next arg type. */
      arglist = chainon (arglist, build_tree_list (NULL_TREE, size_int (what)));

      /* Pass the variable we want to write. */
      arglist = chainon (arglist, build_tree_list (NULL_TREE, p));

      if (field1)
        arglist = chainon (arglist, build_tree_list (NULL_TREE, field1));

      if (field2)
        arglist = chainon (arglist, build_tree_list (NULL_TREE, field2));
    }

  if (rts_id == p_WRITELN)
    {
      /* Inform the RTS that we should do a WriteLn. */
      arglist = chainon (arglist, build_tree_list (NULL_TREE, size_int (P_LINE)));
      length--;
    }
  assert (length == 0);
  if (rts_id == gpc_FORMATSTRING)
    {
      tree res1 = save_expr (rts_call (rts_id, build_pointer_type (string_schema_proto_type), fpar, arglist)),
           res = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (res1)), res1),
           dest = alloca_string (PASCAL_STRING_LENGTH (res));
      return non_lvalue (build (COMPOUND_EXPR, TREE_TYPE (dest), save_expr (assign_string (dest, res)), dest));
    }
  expand_expr_stmt (rts_call (((rts_id == p_WRITESTR || rts_id == ucsd_STR) ? rts_id: r_WRITE),
                              void_type_node, fpar, arglist));
  return NULL_TREE;
}

/* Implement BP's procedure `Val'. */
static void
rts_val (params)
     tree params;
{
  tree par, fpar, string, result_var, code;
  int rts_id;

  /* Check the parameter list and transform it to the one needed by the
     RTS function.

     @@ In the future, minimal and maximal value will be added for
        range checking. */

  par = params;
  if (! par || ! is_string_compatible_type (TREE_VALUE (par), 1))
    {
      error ("argument 1 to `Val' must be a string");
      return;
    }

  /* First parameter: pointer to the string data. */
  string = save_expr_string (TREE_VALUE (par));
  TREE_VALUE (par) = build1 (ADDR_EXPR, ptr_type_node, PASCAL_STRING_VALUE (string));

  /* Second parameter: index of last char in string. */
  TREE_CHAIN (par) = chainon (build_tree_list (NULL_TREE, PASCAL_STRING_LENGTH (string)),
                              TREE_CHAIN (par));
  par = TREE_CHAIN (par);

  /* Third parameter: Flags. */
  TREE_CHAIN (par) = chainon (build_tree_list (NULL_TREE, size_int (get_read_flags ())),
                              TREE_CHAIN (par));
  par = TREE_CHAIN (TREE_CHAIN (par));

  /* Fourth parameter: The result variable.
     (For the user this is the second parameter.) */
  if (! par || (TREE_CODE (TREE_TYPE (TREE_VALUE (par))) != INTEGER_TYPE
                && TREE_CODE (TREE_TYPE (TREE_VALUE (par))) != REAL_TYPE))
    {
      error ("argument 2 to `Val' must be of integer or real type");
      return;
    }
  result_var = TREE_VALUE (par);

  /* The third user parameter is the code we assign the return value of the
     RTS function to. Take it out of business here. */
  if (! TREE_CHAIN (par) || TREE_CODE (TREE_TYPE (TREE_VALUE (TREE_CHAIN (par)))) != INTEGER_TYPE)
    {
      error ("argument 3 to `Val' must be an integer");
      return;
    }
  code = TREE_VALUE (TREE_CHAIN (par));
  TREE_CHAIN (par) = NULL_TREE;

  /* Select the RTS function for this type. */
  if (TREE_CODE (TREE_TYPE (result_var)) == INTEGER_TYPE)
    {
      int sign = !TREE_UNSIGNED (TREE_TYPE (result_var));
      if (TYPE_PRECISION (TREE_TYPE (result_var)) > TYPE_PRECISION (long_integer_type_node))
        rts_id = sign ? bp_VAL_longint_nocheck : bp_VAL_longcard_nocheck;
      else if (TYPE_PRECISION (TREE_TYPE (result_var)) > TYPE_PRECISION (integer_type_node))
        rts_id = sign ? bp_VAL_medint_nocheck : bp_VAL_medcard_nocheck;
      else if (TYPE_PRECISION (TREE_TYPE (result_var)) > TYPE_PRECISION (short_integer_type_node))
        rts_id = sign ? bp_VAL_integer_nocheck : bp_VAL_cardinal_nocheck;
      else if (TYPE_PRECISION (TREE_TYPE (result_var)) > TYPE_PRECISION (signed_char_type_node))
        rts_id = sign ? bp_VAL_shortint_nocheck : bp_VAL_shortcard_nocheck;
      else
        rts_id = sign ? bp_VAL_byteint_nocheck : bp_VAL_bytecard_nocheck;
    }
  else
    {
      /* Real type. */
      if (TYPE_PRECISION (TREE_TYPE (result_var)) > TYPE_PRECISION (double_type_node))
        rts_id = bp_VAL_longreal;
      else if (TYPE_PRECISION (TREE_TYPE (result_var)) > TYPE_PRECISION (float_type_node))
        rts_id = bp_VAL_real;
      else
        rts_id = bp_VAL_shortreal;
    }
  fpar = chainon_pointer (chainon_int (chainon_int (do_ptype (TREE_TYPE (result_var), 1, 1))));
  expand_expr_stmt (build_modify_expr (code, NOP_EXPR, rts_call (rts_id, integer_type_node, fpar, params)));
}

/* Implement Pascal pack and unpack transfer procedures. */
static tree
pascal_unpack_and_pack (unpack, unpacked, packed, ustart)
     int  unpack;  /* Nonzero if UNPACK */
     tree unpacked;
     tree packed;
     tree ustart;
{
  tree utype;
  tree ptype;
  tree len;
  tree pmin, pmax, umin, umax;
  tree check;                   /* Check of arguments */
  tree bits;

  rtx x,y;
  rtx target;
  rtx source;
  rtx length;

  if (unpacked == error_mark_node || packed == error_mark_node)
    return error_mark_node;

  emit_line_note (input_filename, lineno);

  utype = TREE_TYPE (unpacked);
  ptype = TREE_TYPE (packed);
  pmin = TYPE_MIN_VALUE (TYPE_DOMAIN (ptype));
  pmax = TYPE_MAX_VALUE (TYPE_DOMAIN (ptype));
  umin = TYPE_MIN_VALUE (TYPE_DOMAIN (utype));
  umax = TYPE_MAX_VALUE (TYPE_DOMAIN (utype));

  x = expand_expr
    (build_indirect_ref
     (build_unary_op (ADDR_EXPR, build_array_ref (unpacked, ustart), 0),
      "unpacked"),
     0, BLKmode, 0);

  y = expand_expr
    (build_indirect_ref
     (build_unary_op (ADDR_EXPR, packed, 0),
      "packed"),
     0, BLKmode, 0);

  if (unpack)
    {
      target = x;
      source = y;
    }
  else
    {
      target = y;
      source = x;
    }

  /* Length we copy is the length of the packed array */
  len = fold (build (PLUS_EXPR, integer_type_node,
                     fold (build (MINUS_EXPR, integer_type_node, pmax, pmin)),
                     integer_one_node));

  /* Sanity check */
  /* Check that (ustart >= umin) and (ustart..umax >= pmin..pmax) */
  check =
    fold (build (TRUTH_AND_EXPR, boolean_type_node,
                 fold (build (GE_EXPR, boolean_type_node,
                              ustart, umin)),
                 fold (build (GE_EXPR, boolean_type_node,
                              fold (build (PLUS_EXPR, integer_type_node,
                                           fold (build (MINUS_EXPR,
                                                        integer_type_node,
                                                        umax, ustart)),
                                           integer_one_node)),
                              len))));

  if (! TREE_CONSTANT (check))
    /* @@@ Runtime check here variable size array */;
  else if (integer_zerop (check))
    {
      error ("invalid arguments to `%s'", unpack ? "Unpack" : "Pack");
      return error_mark_node;
    }

  bits = count_bits (TREE_TYPE (ptype));
  if (bits && TREE_INT_CST_LOW (bits)
              != TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (ptype))))
    {
      /* Construct a loop like ISO wants (abbreviated):
       *
       *   j := Low (packed);
       *   k := ustart;
       *   repeat
       *     if unpack then
       *       unpacked[k] := packed[j]
       *     else
       *       packed[j] := unpacked[k];
       *     if j < High (packed) then
       *       begin
       *         Inc (j);
       *         Inc (k);
       *       end;
       *   until j >= High (packed);
       */
      tree j = make_new_variable ("pack", TREE_TYPE (TYPE_DOMAIN (ptype)));
      tree k = make_new_variable ("pack", TREE_TYPE (TYPE_DOMAIN (utype)));
      tree condition, packed_j, unpacked_k;
      tree j_as_integer = convert (type_for_size (TYPE_PRECISION (TREE_TYPE (j)),
                                                  TREE_UNSIGNED (TREE_TYPE (j))), j);
      tree k_as_integer = convert (type_for_size (TYPE_PRECISION (TREE_TYPE (k)),
                                                  TREE_UNSIGNED (TREE_TYPE (k))), k);

      expand_expr_stmt (build_modify_expr (j, NOP_EXPR,
                            TYPE_MIN_VALUE (TYPE_DOMAIN (ptype))));
      expand_expr_stmt (build_modify_expr (k, NOP_EXPR,
                            convert (TREE_TYPE (k), ustart)));
      expand_start_loop (1);
      unpacked_k = build_pascal_array_ref (unpacked,
                                           build_tree_list (NULL_TREE, k));
      packed_j = build_pascal_array_ref (packed,
                                         build_tree_list (NULL_TREE, j));
      if (unpack)
        expand_expr_stmt (build_modify_expr (unpacked_k, NOP_EXPR, packed_j));
      else
        expand_expr_stmt (build_modify_expr (packed_j, NOP_EXPR, unpacked_k));
      condition = build_binary_op (LT_EXPR, j,
                                   TYPE_MAX_VALUE (TYPE_DOMAIN (ptype)), 0);
      expand_exit_loop_if_false (0, condition);
      expand_expr_stmt (build_modify_expr (j_as_integer,
                                           PLUS_EXPR, integer_one_node));
      expand_expr_stmt (build_modify_expr (k_as_integer,
                                           PLUS_EXPR, integer_one_node));
      expand_end_loop ();
    }
  else
    {
      /* Not really packed; elements have same size.
       * Get size in bytes.
       */
      tree elem_size = size_in_bytes (TREE_TYPE (utype));

      length = expand_expr
                   (fold (build (MULT_EXPR, integer_type_node, elem_size, len)),
                    0, SImode, 0);

      assert (GET_CODE (source) == MEM && GET_CODE (target) == MEM);
      {
        extern rtx change_address ();

        if (GET_MODE (target) != BLKmode)
          target = change_address (target, BLKmode, 0);

        if (GET_MODE (source) != BLKmode)
          source = change_address (source, BLKmode, 0);

        emit_block_move (target, source, length, TYPE_ALIGN (ptype) / BITS_PER_UNIT);
      }
    }

  return NULL_TREE;
}

static tree
check_argument (arg, rts_name, n, pargtypes, ptype, pcode)
     tree arg;
     char *rts_name;
     int n;
     char **pargtypes;
     tree *ptype;
     enum tree_code *pcode;
{
  char *errstr = NULL_PTR;
  enum tree_code code;
  tree type, val = TREE_VALUE (arg);

  /* @@ quite kludgy */
  char argtype_lower, argtype_lower_orig, argtype = *((*pargtypes)++);
  if (argtype == ',') argtype = *((*pargtypes)++);
  if (!argtype) (*pargtypes)--, argtype = 'x';

  argtype_lower = tolower ((unsigned char)argtype);
  switch (argtype_lower)
    {
      case 'c': case 'u': case 'v': case 'w':
        val = string_may_be_char (val);
        break;
    }
  type = TREE_TYPE (val);
  if (!type)
    return error_mark_node;
  code = TREE_CODE (type);
  if (code == FUNCTION_TYPE)
    {
      /* This is a function without parameters. Call it. */
      val = probably_call_function (val);
      type = TREE_TYPE (val);
      code = TREE_CODE (type);
    }
  #if 0  /* This conversion will be done by the normal parameter conversion run afterwards (I hope ;-) -- Frank */
  if (argtype_lower == 'q' && code == ARRAY_TYPE && TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
    {
      val = build1 (ADDR_EXPR, cstring_type_node, val);
      type = TREE_TYPE (val);
      code = TREE_CODE (type);
    }
  #endif
  if (code == ERROR_MARK)
    return error_mark_node;
  if (ISUPPER ((unsigned char)argtype))
    {
      if (argtype == 'S' && !PASCAL_TYPE_STRING (type))
        errstr = "argument %d to `%s' must be a string schema";
      if (TREE_CONSTANT (val) || TYPE_READONLY (type) || TREE_READONLY (val))
        errstr = "argument %d to `%s' must not be constant or read-only";
      else if (TREE_CODE (val) == COMPONENT_REF && PASCAL_TREE_DISCRIMINANT (TREE_OPERAND (val, 1)))
        errstr = "argument %d to `%s' must not be a schema discriminant";
      else
        typed_const_warning (val);
    }
  argtype_lower_orig = argtype_lower;
  if (argtype_lower == 'v' && !flag_extended_syntax)
    argtype_lower = 'u';
  switch (argtype_lower)
    {
      case 'i': if (code != INTEGER_TYPE)                             errstr = "argument %d to `%s' must be an integer"; break;
      case 'r': if (!INT_REAL (code))                                 errstr = "argument %d to `%s' must be a real or an integer"; break;
      case 'n': if (!IS_NUMERIC (code))                               errstr = "argument %d to `%s' must be an integer, real or complex number"; break;
      case 'c': if (code != CHAR_TYPE)                                errstr = "argument %d to `%s' must be a char"; break;
      case 's': if (!is_string_compatible_type (val, 1))              errstr = "argument %d to `%s' must be a string or char"; break;
      case 'q': if (!(code == POINTER_TYPE && integer_zerop (val)) && TYPE_MAIN_VARIANT (type) != cstring_type_node && !is_string_compatible_type (val, 1)) errstr = "argument %d to `%s' must be a `CString' (`PChar')"; break;
      case 'p': if (code != POINTER_TYPE)                             errstr = "argument %d to `%s' must be a pointer"; break;
      case 'y': if (code != POINTER_TYPE && code != REFERENCE_TYPE)   errstr = "argument %d to `%s' must be of pointer or procedural type"; break;
      case 'f': if (code != FILE_TYPE)                                errstr = "argument %d to `%s' must be a file"; break;
      case 'j': if (code != FILE_TYPE || !TYPE_FILE_TEXT (type))      errstr = "argument %d to `%s' must be a `Text' file"; break;
      case 'k': if (code != FILE_TYPE || TREE_CODE (TREE_TYPE (type)) != VOID_TYPE) errstr = "argument %d to `%s' must be an untyped file"; break;
      case 'm': if (code != SET_TYPE)                                 errstr = "argument %d to `%s' must be a set"; break;
      case 'o': if (!PASCAL_TYPE_OBJECT (type))                       errstr = "argument %d to `%s' must be of object type"; break;
      case 'u': if (!ORDINAL_TYPE (code))                             errstr = "argument %d to `%s' must be of ordinal type"; break;
      case 'v': if (!ORDINAL_TYPE (code) && code != POINTER_TYPE)     errstr = "argument %d to `%s' must be of ordinal or pointer type"; break;
      case 'w': if (!ORDINAL_TYPE (code) && code != REAL_TYPE)        errstr = "argument %d to `%s' must be of ordinal or real type"; break;
      case 't': if (TYPE_MAIN_VARIANT (type) != gpc_type_TIMESTAMP)   errstr = "argument %d to `%s' must be of type `TimeStamp'"; break;
      case 'a': if (TYPE_MAIN_VARIANT (type) != gpc_type_BINDINGTYPE) errstr = "argument %d to `%s' must be of type `BindingType'"; break;
      case 'x': break;
      default: assert (0);
    }
  if (errstr)
    {
      error (errstr, n, rts_name);
      if (argtype_lower_orig == 'v' && code == POINTER_TYPE)
        ptrarith_inform ();
      return error_mark_node;
    }
  TREE_VALUE (arg) = val;
  *ptype = type;
  *pcode = code;
  return val;
}

/* This routine constructs Pascal RTS calls with correct arguments.
 *
 * RTS_ID is the %token number of the RTS routine to call.
 * APAR is a TREE_LIST chain of arguments; args are in the TREE_VALUE field.
 * If there is something in the TREE_PURPOSE field, it is a TREE_LIST
 * node of Write | WriteLn output field length expressions, the first
 * expression is in TREE_VALUE and the second one is in TREE_PURPOSE
 * i.e. actual_parameter : expression : expression.
 */
tree
build_rts_call (rts_id, apar)
     int rts_id;
     tree apar;  /* actual parameters of the routine */
{
  tree fpar = NULL_TREE;  /* formal parameters */
  tree rval = void_type_node;  /* return value; void_type_node if procedure */
  tree actual_return_value = NULL_TREE; /* Value to return for a procedure call if any */
  int actual_return_value_lvalue = 0; /*@@ cf. fjf493.pas */
  tree un_init_this = NULL_TREE; /* If nonzero, try to un-initalize the beast */
  tree post_conversion = NULL_TREE; /* for integer `a pow b': should be inlined */
  enum tree_code post_operator = 0;
  tree post_statement = NULL_TREE; /* for statements automatically executed after calling the RTS procedure */
  tree val  = NULL_TREE, val2 = NULL_TREE, val3 = NULL_TREE, val4 = NULL_TREE;
  tree type = NULL_TREE, type2 = NULL_TREE, type3 = NULL_TREE, type4 = NULL_TREE;
  enum tree_code code = MINUS_EXPR, code2 = MINUS_EXPR, code3 = MINUS_EXPR, code4 = MINUS_EXPR; /* Something that is impossible */
  enum tree_code bitopcode = 0;
  int length;  /* length of the actual parameter list */
  int rts_inline = 0;  /* set to 1 if this is compiled inline */
  int wins = 1;  /* Will be zeroed if actual params are not constants */
  tree temp;
  struct known_id *kptr;
  char *errstr = NULL_PTR, *rts_name = NULL_PTR, *signature = NULL_PTR;
  tree retval = NULL_TREE;

  kptr = KItable;
  while (kptr->name && kptr->value != rts_id)
    kptr++;
  if (kptr->name)
    {
      rts_name = kptr->name;
      if (kptr->iclass != ANY_PASCAL
          && ((kptr->iclass == GNU_PASCAL) ? (pedantic || flag_what_pascal) : PEDANTIC (kptr->iclass)))
        {
          /* @@ Might need to be continued */
          if (kptr->iclass & UCSD_PASCAL)
            error ("`%s' is a UCSD Pascal extension", rts_name);
          else if (kptr->iclass & BORLAND_PASCAL)
            error ("`%s' is a Borland Pascal extension", rts_name);
          else if (kptr->iclass & EXTENDED_PASCAL)
            error ("`%s' is an ISO 10206 Extended Pascal extension", rts_name);
          else if (kptr->iclass & OBJECT_PASCAL)
            error ("`%s' is an Object Pascal extension", rts_name);
          else
            error ("`%s' is a GNU Pascal extension", rts_name);
        }
      signature = kptr->signature;
    }
  else
    switch (rts_id)
      {
        case LEX_AND:   rts_name = "and";        signature = "-Ii"; bitopcode = BIT_AND_EXPR; break;
        case LEX_OR:    rts_name = "or";         signature = "-Ii"; bitopcode = BIT_IOR_EXPR; break;
        case LEX_XOR:   rts_name = "xor";        signature = "-Ii"; bitopcode = BIT_XOR_EXPR; break;
        case LEX_SHL:   rts_name = "shl";        signature = "-Ii"; bitopcode = LSHIFT_EXPR;  break;
        case LEX_SHR:   rts_name = "shr";        signature = "-Ii"; bitopcode = RSHIFT_EXPR;  break;
        case LEX_NOT:   rts_name = "not";        signature = "-I";  break;
        case p_DONEFDR: rts_name = "_p_DoneFDR"; signature = "-f";  break;
        case r_EXPON:   rts_name = "**";         signature = "1nr"; break;
        case r_POW:     rts_name = "pow";        signature = "1ni"; break;
        case '=':       rts_name = "=";          signature = "bss"; break;
        case LEX_NE:    rts_name = "<>";         signature = "bss"; break;
        case '<':       rts_name = "<";          signature = "bss"; break;
        case LEX_LE:    rts_name = "<=";         signature = "bss"; break;
        case '>':       rts_name = ">";          signature = "bss"; break;
        case LEX_GE:    rts_name = ">=";         signature = "bss"; break;
        case LEX_IS:    rts_name = "is";         signature = "bpp"; break;
        case LEX_AS:    rts_name = "as";         signature = "-";   break;
      }
  assert (rts_name && signature);

  /* @@@ wins is not used. (What's it meant for? -- Frank) */
  for (temp = apar; temp && wins; temp = TREE_CHAIN (temp))
    wins = TREE_CONSTANT (TREE_VALUE (temp));
  length = list_length (apar);

  {
    int minarg, maxarg;
    char *tmp = signature + 1;
    while (*tmp && *tmp != ',') tmp++;
    minarg = tmp - (signature + 1);
    if (!*tmp)
      maxarg = minarg;
    else if (*++tmp)
      {
        while (*tmp) tmp++;
        maxarg = tmp - (signature + 2);
      }
    else
      maxarg = -1;
    if (length < minarg)
      errstr = "too few arguments to `%s'";
    else if (maxarg >= 0 && length > maxarg)
      errstr = "too many arguments to `%s'";
    /* @@ should be generalized for n arguments */
    tmp = signature + 1;
    if (length >= 1)
      val = check_argument (apar, rts_name, 1, &tmp, &type, &code);
    if (length >= 2)
      val2 = check_argument (TREE_CHAIN (apar), rts_name, 2, &tmp, &type2, &code2);
    if (length >= 3)
      val3 = check_argument (TREE_CHAIN (TREE_CHAIN (apar)), rts_name, 3, &tmp, &type3, &code3);
    if (length >= 4)
      val4 = check_argument (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (apar))), rts_name, 4, &tmp, &type4, &code4);
    if (val == error_mark_node || val2 == error_mark_node || val3 == error_mark_node || val4 == error_mark_node)
      return error_mark_node;
  }

  switch (*signature)
    {
      case '1': rval = type;                         break;  /* Result type is the same as first argument */
      case '-': rval = void_type_node;               break;
      case 'i': rval = integer_type_node;            break;
      case 'l': rval = long_long_integer_type_node;  break;
      case 'u': rval = long_long_unsigned_type_node; break;
      case 'r': rval = double_type_node;             break;
      case 'e': rval = long_double_type_node;        break;
      case 'z': rval = complex_type_node;            break;
      case 'b': rval = boolean_type_node;            break;
      case 'c': rval = char_type_node;               break;
      case 's': rval = string_type_node;             break;
      case 'q': rval = cstring_type_node;            break;
      case 'p': rval = ptr_type_node;                break;
      default:  assert (0);  /* unknown result type */
    }

  if (!errstr) switch (rts_id) {

  case p_CARD:
    if (TREE_CODE (val) != CONSTRUCTOR && TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
      retval = integer_zero_node;
    else
      retval = rts_call (set_card, integer_type_node, ptype_set (1, NULL_TREE), actual_set_parameters (val));
    rts_inline = 1;
    break;

  case p_ABS:
    if (code == COMPLEX_TYPE)
      {
        rts_id = z_ABS;
        rval = double_type_node;
        fpar = ptype_complex;
      }
    else
      {
        retval = build_unary_op (ABS_EXPR, val, 0);
        rts_inline = 1;
      }
    break;

  case p_SQR:
    retval = build_pascal_binary_op (MULT_EXPR, val, val);
    rts_inline = 1;
    break;

  case p_TRUNC:
  case p_ROUND:
    if (code == INTEGER_TYPE)
      {
        warning ("`%s' applied to integers has no effect", rts_name);
        retval = val;
      }
    else
      {
        if (rts_id == p_ROUND)
          {
            /* ISO Pascal: Round (x) := Trunc (x >= 0.0 ? x + 0.5 : x - 0.5); */
            val = save_expr (val);
            val = build (COND_EXPR, type,
                         build_pascal_binary_op (GE_EXPR, val, real_zero_node),
                         build_pascal_binary_op (PLUS_EXPR, val, real_half_node),
                         build_pascal_binary_op (MINUS_EXPR, val, real_half_node));
          }
        /* @@ Check the return value; maybe wrong TRUNC_EXPR used. */
        retval = convert (long_long_integer_type_node, val);
      }
    rts_inline = 1;
    break;

  case p_SUCC:
  case p_PRED:
    if (length == 1)
      val2 = integer_one_node;
    else if (PEDANTIC (E_O_PASCAL))
      error ("`%s' with two arguments is an ISO 10206 Extended Pascal extension", rts_name);
    retval = convert (type, build_binary_op ((rts_id == p_SUCC) ? PLUS_EXPR : MINUS_EXPR, val, val2, 0));
    rts_inline = 1;
    break;

  case bp_INC:
  case bp_DEC:
    if (code != POINTER_TYPE && code != INTEGER_TYPE)
      val = convert (type_for_size (TYPE_PRECISION (type), TREE_UNSIGNED (type)), val);
    if (length == 1)
      val2 = integer_one_node;
    retval = build_modify_expr (val, (rts_id == bp_INC) ? PLUS_EXPR : MINUS_EXPR, val2);
    rts_inline = 1;
    break;

  case ucsd_FILLCHAR:
    if (code3 != CHAR_TYPE && PEDANTIC (B_D_PASCAL))
      {
        error ("non-`Char' values for argument 3 to `%s' are", rts_name);
        error (" a Borland Pascal extension");
      }
    TREE_VALUE (TREE_CHAIN (TREE_CHAIN (apar))) = val2;
    TREE_VALUE (TREE_CHAIN (apar)) = convert_and_check (unsigned_char_type_node, val3);
    TREE_VALUE (apar) = build_unary_op (ADDR_EXPR, val, 0);
    fpar = chainon_pointer (chainon_int (ptype_sizetype));
    break;

  case bp_MOVE:
  case ucsd_MOVELEFT:
  case ucsd_MOVERIGHT:
    TREE_VALUE (apar) = build_unary_op (ADDR_EXPR, val, 0);
    TREE_VALUE (TREE_CHAIN (apar)) = build_unary_op (ADDR_EXPR, val2, 0);
    fpar = chainon_pointer (chainon_pointer (ptype_sizetype));
    break;

  case ucsd_BLOCKREAD:
  case ucsd_BLOCKWRITE:
    if (length == 3)
      apar = chainon (apar, build_tree_list (NULL_TREE,
               build_indirect_ref (null_pointer_node, "NULL result variable")));
    else if (TREE_TYPE (val4) != unsigned_type_node)
      {
        tree result_tmpvar = make_new_variable ("BlockReadWrite_Result", unsigned_type_node);
        TREE_USED (result_tmpvar) = 1;
        TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (apar)))) = result_tmpvar;
        post_statement = build_modify_expr (val4, NOP_EXPR, result_tmpvar);
      }
    TREE_VALUE (TREE_CHAIN (apar)) = build_unary_op (ADDR_EXPR, val2, 0);
    fpar = chainon (do_ptype (type, 1, 0),
           chainon_pointer (
           chainon (do_ptype (unsigned_type_node, 0, 0),
                    do_ptype (unsigned_type_node, 1, 1))));
    break;

  case ucsd_CONCAT:
    {
      tree arg;
      rts_inline = 1;
      if (length == 1)
        warning ("`%s' with only one argument has no effect", rts_name);
      for (arg = apar; arg; arg = TREE_CHAIN (arg))
        if (!is_string_compatible_type (TREE_VALUE (arg), 1))
          errstr = "arguments to `%s' must be strings or chars";
      if (!errstr)
        {
          retval = val;
          for (arg = TREE_CHAIN (apar); arg; arg = TREE_CHAIN (arg))
            retval = build_pascal_binary_op (PLUS_EXPR, retval, TREE_VALUE (arg));
        }
      break;
    }

  case LEX_NOT:
    if (pedantic || flag_what_pascal)
      error ("procedure-like use of `%s' is a GNU Pascal extension", rts_name);
    retval = build_modify_expr (val, NOP_EXPR, build_pascal_unary_op (BIT_NOT_EXPR, val, 0));
    rts_inline = 1;
    break;

  case LEX_AND:
  case LEX_OR:
  case LEX_XOR:
  case LEX_SHL:
  case LEX_SHR:
    if (pedantic || flag_what_pascal)
      error ("procedure-like use of `%s' is a GNU Pascal extension", rts_name);
    retval = build_modify_expr (val, bitopcode, val2);
    rts_inline = 1;
    break;

  case p_ORD:
    rts_inline = 1;
    if (code == INTEGER_TYPE)
      warning ("`%s' applied to integers has no effect", rts_name);
    retval = convert (integer_type_node, val);
    break;

  case p_CHR:
    retval = convert (char_type_node, val);
    rts_inline = 1;
    break;

  case gpc_UPCASE:
    if (flag_what_pascal & B_D_PASCAL)
      rts_id = bp_UPCASE;
    /* FALLTHROUGH */
  case gpc_LOCASE:
    fpar = ptype_char;
    break;

  case gpc_SETFILETIME:
    /* This code assumes that `UnixTimeType' is `LongInt'. */
    fpar = chainon (do_ptype (type, 1, 0),
           chainon (do_ptype (long_long_integer_type_node, 0, 0),
                    ptype_longint));
    break;

  case delphi_INITIALIZE:
  case delphi_FINALIZE:
    if (pedantic && !contains_auto_initialized_part_p (type, rts_id == delphi_FINALIZE))
      {
        if (rts_id == delphi_FINALIZE)
          pedwarn ("variable does not need any finalization");
        else
          pedwarn ("variable does not need any initialization");
      }
    init_any (val, rts_id == delphi_FINALIZE);
    rts_inline = 1;
    retval = NULL_TREE;
    rval = integer_type_node;  /* not void, nothing to call */
    break;

  case bp_INCLUDE:
  case bp_EXCLUDE:
    if (comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (type)), TYPE_MAIN_VARIANT (type2)) == 0)
      errstr = "incompatible type for argument 2 to `%s'";
    apar = chainon (actual_set_parameters (val), build_tree_list (NULL_TREE, convert (integer_type_node, val2)));
    fpar = ptype_set (0, ptype_int);
    break;

  case bp_RANDOM:
    if (length == 0)
      {
        rts_id = bp_RANDREAL;
        rval = long_double_type_node;
        fpar = ptype_void;
      }
    else
      fpar = do_ptype (long_long_unsigned_type_node, 0, 1);
    break;

  case bp_RANDOMIZE:
    fpar = ptype_void;
    break;

  case p_ODD:
    retval = convert (boolean_type_node,
                      build_binary_op (BIT_AND_EXPR, val, integer_one_node, 1));
    rts_inline = 1;
    break;

  case gpc_SETTYPE:
    if (!flag_extended_syntax)
      warning ("please specify `{$X+}' when using `%s'", rts_name);
    retval = build_modify_expr (convert (gpc_type_PObjectType, build_component_ref (val, get_identifier ("vmt"))), NOP_EXPR, val2);
    rts_inline = 1;
    break;

  case gpc_SETLENGTH:
    retval = build_modify_expr (build_component_ref (val, get_identifier ("length")), NOP_EXPR, val2);
    rts_inline = 1;
    break;

  case p_LENGTH:
    retval = non_lvalue (convert (integer_type_node, PASCAL_STRING_LENGTH (val)));
    rts_inline = 1;
    break;

  case bp_PARAMCOUNT:
    retval = build_pascal_binary_op (MINUS_EXPR,
                                     get_builtin_variable ("_p_argc", integer_type_node),
                                     integer_one_node);
    rts_inline = 1;
    break;

  case bp_PARAMSTR:
    {
      tree condition;
      tree argc_var = get_builtin_variable ("_p_argc", integer_type_node);
      tree argv_var = get_builtin_variable ("_p_argv", build_pointer_type (cstring_type_node));
      /* CString2String (((val < 0) or (val >= _p_argc)) ? nil : _p_argv[val]) */
      condition = build_pascal_binary_op (GE_EXPR, val, argc_var);
      /* Save one comparison when VAL is unsigned. */
      if (!TREE_UNSIGNED (type))
        condition = build_pascal_binary_op (TRUTH_ORIF_EXPR,
                      build_pascal_binary_op (LT_EXPR, val, integer_zero_node), condition);
      val = build (COND_EXPR, cstring_type_node, condition, null_pointer_node,
                   build_array_ref (argv_var, val));
      type = TREE_TYPE (val);
      code = TREE_CODE (type);
      rts_id = gpc_CSTRING2STRING;
    }
    /* FALLTHROUGH */
  case gpc_CSTRING2STRING:
    {
      tree saved_val, stmt, strlength;
      rts_inline = 1;
      if (code == POINTER_TYPE && integer_zerop (val))
        {
          /* Explicit `nil'. */
          tree empty_string = build_string (1, "");
          TREE_TYPE (empty_string) = char_array_type_node;
          retval = new_string_by_model (NULL_TREE, empty_string, 1);
          break;
        }

      saved_val = save_expr (val);

      /* var capacity: Integer = (saved_val = nil) ? 0 : __builtin_strlen|Length (saved_val); */
      if (TYPE_MAIN_VARIANT (type) == cstring_type_node)
        strlength = build (COND_EXPR, integer_type_node,
                           build_pascal_binary_op (EQ_EXPR, null_pointer_node, saved_val),
                           integer_zero_node,
                           build_function_call (lookup_name (get_identifier ("__builtin_strlen")),
                                                build_tree_list (NULL_TREE, saved_val)));
      else
        strlength = PASCAL_STRING_LENGTH (saved_val);
#if 0
      tree capacity;
      capacity = make_new_variable ("cstring2string_capacity", integer_type_node);
      TREE_USED (capacity) = 1;
      capacity = build (COMPOUND_EXPR, integer_type_node,
                        build_modify_expr (capacity, NOP_EXPR, strlength),
                        capacity);

      /* alloca() the return value. */
      retval = alloca_string (capacity);
      TREE_USED (retval) = 1;
#else
      retval = alloca_string (strlength);
#endif

      /* _p_copycstring (saved_val, retval); */
      fpar = chainon_cstring (ptype_string_schema);
      apar = chainon (apar, build_tree_list (NULL_TREE, retval));
      TREE_VALUE (apar) = saved_val;
      stmt = rts_call (rts_id, void_type_node, fpar, apar);

      /* return retval^; */
      retval = non_lvalue (
                 build (COMPOUND_EXPR, TREE_TYPE (retval),
                        build (SAVE_EXPR, void_type_node, stmt,
                               current_function_decl, NULL_RTX),
                        retval));
      break;
    }

  case gpc_NEWCSTRING:
    fpar = ptype_const_string_schema;
    break;

  case gpc_CSTRINGCOPYSTRING:
    fpar = chainon_cstring (ptype_const_string_schema);
    break;

  case gpc_STRING2CSTRING:
    {
      tree capacity = make_new_variable ("string2cstring_capacity", integer_type_node);
      expand_expr_stmt (build_modify_expr (capacity, NOP_EXPR,
                                           PASCAL_STRING_LENGTH (val)));
      rval = build_array_type (char_type_node,
                               build_range_type (integer_type_node,
                                                 integer_zero_node, capacity));
      retval = make_new_variable ("string2cstring_result", rval);
      TREE_USED (retval) = 1;
      fpar = chainon_cstring (ptype_const_string_schema);
      apar = chainon (build_tree_list (NULL_TREE, retval), apar);
      retval = build (COMPOUND_EXPR, cstring_type_node,
                      rts_call (gpc_CSTRINGCOPYSTRING, void_type_node, fpar, apar),
                      build1 (ADDR_EXPR, cstring_type_node, retval));
      rts_inline = 1;
      break;
    }

  case p_CMPLX:
    {
      tree complex = TREE_TYPE (complex_type_node);
      if (type != complex)
        val = convert (complex, val);
      if (type2 != complex)
        val2 = convert (complex, val2);
      retval = build (COMPLEX_EXPR, complex_type_node, val, val2);
      rts_inline = 1;
      break;
    }

  case p_RE:
    if (INT_REAL (code))
      {
        warning ("`%s' applied to real numbers has no effect", rts_name);
        retval = val;
      }
    else
      retval = build_unary_op (REALPART_EXPR, val, 1);
    rts_inline = 1;
    break;

  case p_IM:
    if (INT_REAL (code))
      {
        warning ("`%s' applied to real numbers always yields 0", rts_name);
        retval = real_zero_node;
      }
    else
      retval = build_unary_op (IMAGPART_EXPR, val, 1);
    rts_inline = 1;
    break;

  case gpc_MAX:
  case gpc_MIN:
    rts_inline = 1;
    if (code == REAL_TYPE || code2 == REAL_TYPE)
      {
        if (code == INTEGER_TYPE)
          {
            val = convert (type2, val);
            type = type2;
          }
        else if (code2 == INTEGER_TYPE)
          val2 = convert (type, val2);
      }
    else if (code != code2)
      {
        errstr = "both arguments to `%s' must have the same type";
        break;
      }
    retval = convert (type, build_pascal_binary_op (rts_id == gpc_MAX ? MAX_EXPR : MIN_EXPR, val, val2));
    break;

  case p_PACK:
    {
      tree unpacked_domain = TYPE_DOMAIN (type);
      rts_inline = 1;
      if (code3 != ARRAY_TYPE || !PASCAL_TYPE_PACKED (type3))
        errstr = "argument 3 to `%s' must be a packed array";
      else if (code != ARRAY_TYPE || PASCAL_TYPE_PACKED (type))
        errstr = "argument 1 to `%s' must be an unpacked array";
      else if (code2 != TREE_CODE (unpacked_domain)
               && (TREE_CODE (unpacked_domain) != INTEGER_TYPE
                   || code2 != TREE_CODE (TREE_TYPE (unpacked_domain))))
        errstr = "argument 2 to `%s' must be of unpacked array index type";
      else if (TREE_CODE (TREE_TYPE (type)) != TREE_CODE (TREE_TYPE (type3)))
        errstr = "source and destination arrays in `%s' must be of the same type";
      else
        retval = pascal_unpack_and_pack (0, val, val3, val2);
      rval = integer_type_node;  /* not void; pascal_unpack_and_pack does the call already */
      break;
    }

  case p_UNPACK:
    {
      tree unpacked_domain = TYPE_DOMAIN (type2);
      rts_inline = 1;
      /* I just wonder why on venus they had to shuffle these */
      if (code2 != ARRAY_TYPE || PASCAL_TYPE_PACKED (type2))
        errstr = "argument 2 to `%s' must be an unpacked array";
      else if (code != ARRAY_TYPE || !PASCAL_TYPE_PACKED (type))
        errstr = "argument 1 to `%s' must be a packed array";
      else if (code3 != TREE_CODE (unpacked_domain)
               && (TREE_CODE (unpacked_domain) != INTEGER_TYPE
                   || code3 != TREE_CODE (TREE_TYPE (unpacked_domain))))
        errstr = "argument 3 to `%s' must be of unpacked array index type";
      else if (TREE_CODE (TREE_TYPE (type)) != TREE_CODE (TREE_TYPE (type2)))
        errstr = "source and destination arrays in `%s' must be of the same type";
      else
        retval = pascal_unpack_and_pack (1, val2, val, val3);
      rval = integer_type_node;  /* not void; pascal_unpack_and_pack does the call already */
      break;
    }

  case bp_ASSIGNED:
    rts_inline = 1;
    retval = build (NE_EXPR, boolean_type_node, integer_zero_node, val);
    break;

  /* Calls to RTS */

  /* statements */
  case p_NEW:
  case bp_GETMEM:
    {
      /* There are a lot of allowed call styles for `New':
       *
       *   New (PtrVar);                                 (SP)
       *   Ptr := New (PlainPtrType);                    (BP)
       *
       *   New (VariantRecordPtr, TagFields);            (SP)
       *
       *   New (ObjectPtr, ConstructorCall);             (BP)
       *   Ptr := New (ObjectPtrType, ConstructorCall);  (BP)
       *
       *   New (SchemaPtr, Discriminants);               (EP)
       *   Ptr := New (SchemaPtrType, Discriminants);    (GPC)
       *
       *   GetMem (PtrVar, Size);                        (BP)
       *   Ptr := GetMem (Size);                         (GPC)
       *
       * Internally, we call `New' and `GetMem' as functions.
       * If called as a procedure, we do the assignment inline.
       * The only parameter to the RTS is always the size of
       * the object being created (of type `SizeType').
       */
      tree result, save_type = NULL_TREE, tags = NULL_TREE;
      if (rts_id == bp_GETMEM)
        {
          if (length == 2)
            {
              if (code != POINTER_TYPE)
                errstr = "first of two arguments to `%s' must be a pointer";
            }
          else if (code != INTEGER_TYPE)
            errstr = "a single argument to `%s' must be an integer";
          if (errstr)
            break;
          if (length == 1)
            type = ptr_type_node;
          else
            apar = TREE_CHAIN (apar);
        }
      else
        {
          int schema_ids = 0;
          tree ptype = TREE_TYPE (type);
          if (TREE_CODE (ptype) == VOID_TYPE && (flag_what_pascal & B_D_PASCAL) == 0)
            warning ("argument to `%s' should not be an untyped pointer", rts_name);
          if (PASCAL_TYPE_UNDISCRIMINATED_STRING (ptype)
              || PASCAL_TYPE_PREDISCRIMINATED_STRING (ptype)
              || PASCAL_TYPE_UNDISCRIMINATED_SCHEMA (ptype)
              || PASCAL_TYPE_PREDISCRIMINATED_SCHEMA (ptype))
            {
              schema_ids = number_of_schema_discriminants (ptype);
              assert (schema_ids);

              /* If this is a schema type, `New' does two things:
               * - select the type of the object
               * - allocate the required space for the object.
               * So we must create a new type for the object with the
               * schema discriminants filled with the values. */

              if (length != schema_ids + 1)
                {
                  error ("`%s' applied to this schema requires %d %s", rts_name,
                         schema_ids, schema_ids > 1 ? "discriminant values"
                                                    : "discriminant value");
                  return error_mark_node;
                }

              if (PASCAL_TYPE_STRING (ptype))
                type = build_pointer_type (build_pascal_string_schema (val2));
              else if (PASCAL_TYPE_SCHEMA (ptype))
                {
                  tree schema_type = ptype, tmp;
                  assert (TREE_CODE (val) == TYPE_DECL
                          ? PASCAL_TYPE_UNDISCRIMINATED_SCHEMA (schema_type)
                          : PASCAL_TYPE_PREDISCRIMINATED_SCHEMA (schema_type));
                  /* Get the base type, i.e. the undiscriminated schema type. */
                  while (TYPE_LANG_BASE (schema_type) && TYPE_LANG_BASE (schema_type) != schema_type)
                    schema_type = TYPE_LANG_BASE (schema_type);
                  if (TREE_CODE (schema_type) == TYPE_DECL)
                    schema_type = TREE_TYPE (schema_type);
                  for (tmp = TREE_CHAIN (apar); tmp; tmp = TREE_CHAIN (tmp))
                    TREE_VALUE (tmp) = save_expr (TREE_VALUE (tmp));
                  type = build_discriminated_schema_type (schema_type, TREE_CHAIN (apar));
                  TYPE_SCHEMA_NEW_CALL (type) = integer_one_node;
                  type = build_pointer_type (type);
                }
              else
                warning ("Internal GPC problem: malformed string or schema");

              /* Force the type of the variable to be a pointer to
               * the discriminated schema type instead of a pointer
               * to the schema type. This will be undone after the
               * newly allocated object will be initialized. */
              save_type = TREE_TYPE (val);
              TREE_TYPE (val) = type;
            }
          if (length != 1)
            {
              /* Object constructor calls are handled by the parser
               * so the remaining values are for schema discriminants
               * and tag fields of variant records. */
              int i;
              tags = TREE_CHAIN (apar);
              for (i = 0; i < schema_ids && tags; i++)
                tags = TREE_CHAIN (tags);
              length -= schema_ids;
              if (PEDANTIC (~U_B_D_PASCAL))
                error ("UCSD and Borland Pascal do not support tag fields in `%s'", rts_name);
            }
          apar = build_tree_list (NULL_TREE, object_size (TREE_TYPE (type)));
        }

      /* Call the library function. */
      rts_inline = 1;
      fpar = do_ptype (sizetype, 0, 1);
      retval = rts_call (rts_id, type, fpar, apar);

      if (TREE_CODE (val) == TYPE_DECL || (rts_id == bp_GETMEM && length == 1))
        {
          /* Function-style call.
           * We use a temporary variable here because we want to avoid
           * this function to be called more than once if it returns a
           * string or schema. */
          result = make_new_variable ("new", TREE_TYPE (retval));
          expand_expr_stmt (build_modify_expr (result, NOP_EXPR, retval));
          retval = result;
          /* @@ This would be easier and solve fjf226k.pas, but then
                init_any below must return an expression and we have
                to use COMPOUND_EXPR's here (also for assign_tags).
                Since init_any might produce loops, this seems to
                require a statement-expression.
          retval = result = save_expr (retval); */
        }
      else
        {
          /* Procedure-style call. Do the assignment to the first parameter here. */
          expand_expr_stmt (build_modify_expr (val, NOP_EXPR, retval));

          /* Mark the pointer as being assigned. */
          if (TREE_CODE (val) == VAR_DECL)
            PASCAL_VALUE_ASSIGNED (val) = 1;

          retval = void_type_node;
          result = val;
        }

      /* Initialize the object we get from `New'. */
      if (rts_id == p_NEW)
        init_any (build_indirect_ref (result, "New"), 0);

      /* If there are tag fields, assign them. */
      tags = assign_tags (build_indirect_ref (result, "New"), tags);
      if (tags)
        expand_expr_stmt (tags);

      /* If this was a schema type, restore the undiscriminated schema type
       * after init_any has done its job to avoid type conflicts when this
       * pointer is assigned to some lvalue.
       * VAL might be a type decl, thus we must repair it, too. */
      if (save_type)
        TREE_TYPE (result) = TREE_TYPE (val) = save_type;
      break;
    }

  case p_DISPOSE:
    if (integer_zerop (val))
      warning ("disposing `nil' has no effect");
    if (length > 1)
      {
        static int informed = 0;
        if ((pedantic || flag_what_pascal) && ! informed)
          {
            warning ("tag fields ignored in `%s'", rts_name);
            informed++;
          }
        apar = copy_node (apar);
      }
    fpar = ptype_pointer;
    break;

  case bp_FREEMEM:
    if (integer_zerop (val))
      warning ("`FreeMem (nil)' has no effect");
    if (length > 1)
      {
        /* @@ Perhaps we should do a run-time check with the second parameter? */
        apar = copy_node (apar);
      }
    fpar = ptype_pointer;
    break;

  case p_POSITION:
  case p_LASTPOSITION:
    fpar = do_ptype (type, 1, 1);
    if (TYPE_DOMAIN (type))
      {
        rts_inline = 1;  /* Fake it is inline */
        retval = convert (TREE_TYPE (TYPE_DOMAIN (type)),
                          build_binary_op (PLUS_EXPR,
                                           rts_call (rts_id, rval, fpar, apar),
                                           convert (rval, TYPE_MIN_VALUE (TYPE_DOMAIN (type))),
                                           0));
      }
    else if (PEDANTIC (B_D_PASCAL))
      error ("ISO 10206 Extended Pascal does not allow direct access to normal files");
    break;

  case bp_FILESIZE:
  case bp_FILEPOS:
    fpar = do_ptype (type, 1, 1);
    break;

  case p_PAGE:
    if (length == 0)
      apar = build_tree_list (NULL_TREE, get_standard_output ());
    /* FALLTHROUGH */
  case p_CLOSE:
  case p_DONEFDR:
  case p_UPDATE:
  case p_PUT:
  case p_GET:
  case bp_TRUNCATE:
  case bp_FLUSH:
  case bp_ERASE:
    fpar = do_ptype (TREE_TYPE (TREE_VALUE (apar)), 1, 1);
    break;

  case bp_RENAME:
    fpar = chainon (do_ptype (type, 1, 0), ptype_const_string_schema);
    break;

  case bp_RUNERROR:
    if (length == 0)
      apar = build_tree_list (NULL_TREE, build_int_2 (-1, -1));
    fpar = ptype_int;
    break;

  case p_HALT:
    if (length == 0)
      apar = build_tree_list (NULL_TREE, integer_zero_node);
    fpar = ptype_int;
    break;

  case p_BINDING:
    {
      tree stype = gpc_type_BINDINGTYPE;
      /* Pass a reference to a temporary variable; RTS
         fills it it instead of returning a record type. */
      actual_return_value = make_new_variable ("binding", stype);
      actual_return_value_lvalue = 1;
      fpar = chainon (do_ptype (type, 1, 0), do_ptype (stype,1, 1));
      apar = chainon (apar, build_tree_list (NULL_TREE, actual_return_value));
      break;
    }

  case p_UNBIND:
    fpar = do_ptype (type, 1, 1);
    break;

  case p_BIND:
    #if 0
    /* Why not??? */
    if (! PASCAL_EXTERNAL_OBJECT (apar))
      errstr = "GPC supports `%s' only for external files";
    #endif
    /* @@@@@@ I'm too tired to do this now:
     * For variable parameters the bindability is determined by
     * the type of the actual parameter, at least when it is a file
     * type.
     * Now I allow binding of all var file parameters, not only
     * those that are declared bindable.
     * @@@@@ FIXME
     */
    if (((flag_what_pascal & E_O_PASCAL) != 0
           && (flag_what_pascal & ! B_D_PASCAL) == 0)
         && (! PASCAL_TYPE_BINDABLE (type)
             && !((TREE_CODE (val) == INDIRECT_REF)
                  && ((TREE_CODE (TREE_OPERAND (val, 0)) == PARM_DECL)
                      || ((TREE_CODE (TREE_OPERAND (val, 0)) == CONVERT_EXPR)
                          && (TREE_CODE (TREE_OPERAND (TREE_OPERAND (val, 0), 0))
                              == PARM_DECL))))))
      errstr = "type has not been declared `bindable'";
    fpar = chainon (do_ptype (type, 1,0), do_ptype (type2,1,1));
    break;

  case p_DATE:
  case p_TIME:
    {
      /* A REFERENCE_TYPE to val and an additional parameter that is the
         location where RTS stores DATE/TIME conversion results. */
      tree stype = (rts_id == p_DATE) ? gpc_type_DATE : gpc_type_TIME;
      actual_return_value = make_new_variable ("times", stype);
      TREE_USED (actual_return_value) = 1;
      fpar = chainon (do_ptype (type, 1, 0), do_ptype (stype, 1, 1));
      apar = chainon (apar, build_tree_list (NULL_TREE, actual_return_value));
      break;
    }

  case p_GETTIMESTAMP:
    fpar = do_ptype (type, 1, 1);
    break;

  case ucsd_SEEK:
  case p_SEEKUPDATE:
  case p_SEEKREAD:
  case p_SEEKWRITE:
    fpar = chainon (do_ptype (type, 1, 0), ptype_longint);
    if (!TYPE_DOMAIN (type))
      {
        if (pedantic || flag_what_pascal)
          error ("ISO 10206 Extended Pascal does not allow direct access to normal files");
      }
    else if (comptypes (TYPE_MAIN_VARIANT (TREE_TYPE (TYPE_DOMAIN (type))), TYPE_MAIN_VARIANT (type2)) == 0)
      errstr = "index type does not match direct access file range type";
    else
      {
        val2 = build_binary_op (MINUS_EXPR, val2, TYPE_MIN_VALUE (TYPE_DOMAIN (type)), 0);
        TREE_VALUE (TREE_CHAIN (apar)) = val2;
      }
    break;

  case p_EOF:
  case p_EOLN:
    if (length == 0)
      apar = build_tree_list (NULL_TREE, get_standard_input ());
    fpar = do_ptype (TREE_TYPE (TREE_VALUE (apar)), 1, 1);
    break;

  case p_POLAR:
    fpar = chainon_double (ptype_double);
    break;

  case p_SQRT:
  case p_SIN:
  case p_COS:
  case p_EXP:
  case p_LN:
  case p_ARCTAN:
    if (code == COMPLEX_TYPE)
      {
        switch (rts_id)
          {
            case p_SQRT:   rts_id = z_SQRT;   break;
            case p_SIN:    rts_id = z_SIN;    break;
            case p_COS:    rts_id = z_COS;    break;
            case p_EXP:    rts_id = z_EXP;    break;
            case p_LN:     rts_id = z_LN;     break;
            case p_ARCTAN: rts_id = z_ARCTAN; break;
            default:       assert (0);
          }
        rval = complex_type_node;
        fpar = ptype_complex;
      }
    else if (code == REAL_TYPE && TYPE_PRECISION (type) > TYPE_PRECISION (double_type_node))
      {
        switch (rts_id)
          {
            case p_SQRT:   rts_id = pp_SQRT;   break;
            case p_SIN:    rts_id = pp_SIN;    break;
            case p_COS:    rts_id = pp_COS;    break;
            case p_EXP:    rts_id = pp_EXP;    break;
            case p_LN:     rts_id = pp_LN;     break;
            case p_ARCTAN: rts_id = pp_ARCTAN; break;
            default:       assert (0);
          }
        rval = long_double_type_node;
        fpar = ptype_long_double;
      }
    else
      fpar = ptype_double;
    break;

  case ucsd_INT:
    if (code == INTEGER_TYPE)
      {
        warning ("`%s' applied to integers has no effect", rts_name);
        retval = val;
        rts_inline = 1;
      }
    fpar = ptype_long_double;
    break;

  case bp_FRAC:
    if (code == INTEGER_TYPE)
      {
        warning ("`%s' applied to integers always yields 0", rts_name);
        /* Return 0, but evaluate val for side-effects */
        retval = build (COMPOUND_EXPR, integer_type_node, val, integer_zero_node);
        rts_inline = 1;
      }
    fpar = ptype_long_double;
    break;

  case p_ARG:
    fpar = ptype_complex;
    break;

  case r_EXPON:
    /* Exponent type is checked above and in the parser. */
    if (code == COMPLEX_TYPE)
      rts_id = z_EXPON;
    else if (TYPE_PRECISION (type) > TYPE_PRECISION (double_type_node)
             || TYPE_PRECISION (type2) > TYPE_PRECISION (double_type_node))
      {
        rts_id = rr_EXPON;
        rval = long_double_type_node;
      }
    else
      rval = double_type_node;
    fpar = chainon (do_ptype (rval, 0, 0), do_ptype (rval, 0, 1));
    break;

  case r_POW:
    /* Exponent type is checked above and in the parser. */
    if (code == COMPLEX_TYPE)
      rts_id = z_POW;
    else if (code == INTEGER_TYPE)
      {
        /* @@ Calculate in double type, then convert back to int. Should be inlined. */
        post_conversion = integer_type_node;
        rval = double_type_node;
      }
    else if (TYPE_PRECISION (type) > TYPE_PRECISION (double_type_node))
      {
        rts_id = rr_POW;
        rval = long_double_type_node;
      }
    fpar = chainon (do_ptype (rval, 0, 0), do_ptype (type2, 0, 1));
    break;

  case p_EXTEND:
  case bp_APPEND:
  case p_RESET:
  case p_REWRITE:
    {
      tree file_name = NULL_TREE, file_name_given;
      tree buffer_size = NULL_TREE;

      if ((rts_id == p_EXTEND || rts_id == bp_APPEND) && PEDANTIC (~B_D_PASCAL) && !TYPE_FILE_TEXT (type))
        error ("`%s' for non-text files is a GNU Pascal extension", rts_name);

      if (length >= 2)
        {
          if (is_string_compatible_type (val2, 1))
            file_name = val2;
          else if (code2 == INTEGER_TYPE)
            buffer_size = val2;
          else
            errstr = "type mismatch in optional argument to `%s'";
          if (length >= 3)
            {
              if (buffer_size)
                errstr = "file buffer size given twice to `%s'";
              else
                buffer_size = val3;
            }
        }

      if (file_name)
        file_name_given = boolean_true_node;
      else
        {
          file_name = build_string (1, "");
          TREE_TYPE (file_name) = char_array_type_node;
          file_name_given = boolean_false_node;
        }

      if (!buffer_size && TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
        {
          if (flag_what_pascal & B_D_PASCAL)
            {
              warning ("unspecified buffer size for untyped file defaults to 128 in `%s'", rts_name);
              buffer_size = build_int_2 (128, 0);
            }
          else
            errstr = "missing buffer size argument to `%s' for untyped file";
        }

      if (buffer_size)
        {
          if (PEDANTIC (U_B_D_PASCAL))
            error ("file buffer size arguments to `%s' are a UCSD Pascal extension", rts_name);
          if (TREE_CODE (TREE_TYPE (type)) != VOID_TYPE)
            error ("file buffer size argument to `%s' only allowed for untyped files", rts_name);
          if (TREE_CODE (buffer_size) == INTEGER_CST && !INT_CST_LT (integer_zero_node, buffer_size))
            error ("file buffer size in `%s' must be > 0", rts_name);
        }
      else
        buffer_size = build_int_2 (1, 0);  /* @@ for untyped files used as `AnyFile' which is `Text' currently; otherwise `-1, -1' might be better */

      apar = chainon (build_tree_list (NULL_TREE, val),
                      chainon (build_tree_list (NULL_TREE, file_name),
                      chainon (build_tree_list (NULL_TREE, file_name_given),
                               build_tree_list (NULL_TREE, buffer_size))));
      fpar = chainon (do_ptype (type, 1, 0),
                      chainon_const_string_schema (chainon (do_ptype (boolean_type_node, 0, 0),
                               ptype_int)));
      break;
    }

  case ucsd_STR:
  case p_WRITESTR:
  case gpc_FORMATSTRING:
  case p_WRITE:
  case p_WRITELN:
    emit_line_note (input_filename, lineno);
    return rts_write (rts_id, apar);

  case p_READSTR:
  case p_READ:
  case p_READLN:
    emit_line_note (input_filename, lineno);
    rts_read (rts_id, apar);
    return NULL_TREE;

  case bp_VAL:
    emit_line_note (input_filename, lineno);
    rts_val (apar);
    return NULL_TREE;

  case ucsd_INSERT:
    /* Add an implicit fourth parameter that tells whether the
       string shall be truncated if it becomes too long.
       @@ Currently, we always pass `True'. */
    apar = chainon (apar, build_tree_list (NULL_TREE, boolean_true_node));
    fpar = chainon_const_string_schema (chainon_string_schema (chainon_int (ptype_bool)));
    break;

  case ucsd_DELETE:
    if (length == 2)
      {
        if (PEDANTIC (~U_B_D_PASCAL))
          error ("`%s' with only two arguments is a GNU Pascal extension", rts_name);
        apar = chainon (apar, build_tree_list (NULL_TREE, integer_maxint_node));
      }
    fpar = chainon_string_schema (chainon_int (ptype_int));
    break;

  /* Other extensions. */
  case p_MARK:
  case p_RELEASE:
    fpar = do_ptype (type, rts_id == p_MARK, 1);
    break;

  case p_DEFINESIZE:
    fpar = chainon (do_ptype (type, 1, 0), ptype_longint);
    break;

  case bp_ASSIGN:
    fpar = chainon (do_ptype (type, 1, 0), ptype_const_string_schema);
    break;

  case bp_CHDIR:
  case bp_MKDIR:
  case bp_RMDIR:
    fpar = ptype_const_string_schema;
    break;

  case ucsd_IORESULT:
    fpar = ptype_void;
    break;

  case p_EMPTY:
    fpar = do_ptype (type, 1, 1);
    break;

  case ucsd_COPY:
  case p_SUBSTR:
    {
      int truncate = (rts_id == ucsd_COPY);
      /* If 3rd parameter is missing, pass MaxInt and let the RTS truncate */
      if (length == 2)
        {
          if (rts_id == ucsd_COPY && PEDANTIC (~U_B_D_PASCAL))
            error ("`%s' with only two arguments is a GNU Pascal extension", rts_name);
          truncate = 1;
          apar = chainon (apar, build_tree_list (NULL_TREE, integer_maxint_node));
        }
      /* Allocate a new string and pass that to RTS. */
      actual_return_value = new_string_by_model (NULL_TREE, val, 0);
      apar = chainon (apar, build_tree_list (NULL_TREE, actual_return_value));
      apar = chainon (apar, build_tree_list (NULL_TREE,
                      truncate ? boolean_true_node : boolean_false_node));
      fpar = chainon_const_string_schema (chainon_int (chainon_int (chainon_string_schema (ptype_bool))));
      break;
    }

  case p_TRIM:
    /* Allocate a new string and pass that to RTS. */
    actual_return_value = new_string_by_model (NULL_TREE, val, 0);
    apar = chainon (apar, build_tree_list (NULL_TREE, actual_return_value));
    fpar = chainon_const_string_schema (ptype_string_schema);
    break;

  case p_INDEX:
  case ucsd_POS:
    if (rts_id == ucsd_POS)
      {
        /* Same as p_INDEX, but swap the first and second arguments. */
        TREE_VALUE (apar) = val2;
        val2 = TREE_VALUE (TREE_CHAIN (apar)) = val;
        val = TREE_VALUE (apar);
      }
    fpar = chainon_const_string_schema (ptype_const_string_schema);
    break;

  /* String comparisons */
  case p_EQ:
  case p_NE:
  case p_LT:
  case p_LE:
  case p_GT:
  case p_GE:
  case '=':
  case LEX_NE:
  case '<':
  case LEX_LE:
  case '>':
  case LEX_GE:
    {
      /* First, reduce the number of operators from 12 to 4 :-) */
      int swapargs = 0, invertresult = 0;
      switch (rts_id)
        {
          case LEX_NE: rts_id = '=';                invertresult = 1; break;
          case '>':    rts_id = '<';  swapargs = 1;                   break;
          case LEX_GE: rts_id = '<';                invertresult = 1; break;
          case LEX_LE: rts_id = '<';  swapargs = 1; invertresult = 1; break;
          case p_NE:   rts_id = p_EQ;               invertresult = 1; break;
          case p_GT:   rts_id = p_LT; swapargs = 1;                   break;
          case p_GE:   rts_id = p_LT;               invertresult = 1; break;
          case p_LE:   rts_id = p_LT; swapargs = 1; invertresult = 1; break;
          default: /* nothing */;
        }
      if (swapargs)
        {
          TREE_VALUE (apar) = val2;
          val2 = TREE_VALUE (TREE_CHAIN (apar)) = val;
          val = TREE_VALUE (apar);
        }

      /* If flag_exact_compare_strings is nonzero, comparisons are never padded with spaces */
      if (flag_exact_compare_strings)
        {
          if (rts_id == '=')
            rts_id = p_EQ;
          else if (rts_id == '<')
            rts_id = p_LT;
        }

#if 1 /* Optimize non-padding comparisons against the constant empty string */
      if (rts_id == p_EQ || rts_id == p_LT)
        {
          tree comp_empty = NULL;
          #define IS_CONSTANT_EMPTY_STRING(t) \
            (TREE_CODE (t) == STRING_CST && TREE_STRING_LENGTH (t) == 1)
          if (IS_CONSTANT_EMPTY_STRING (val))
            {
              if (rts_id == p_LT)  /* '' < s is equivalent to '' <> s */
                {
                  rts_id = p_EQ;
                  invertresult = !invertresult;
                }
              comp_empty = val2;
            }
          else if (IS_CONSTANT_EMPTY_STRING (val2))
            {
              if (rts_id == p_LT)  /* s < '' is impossible */
                {
                  if (invertresult)
                    {
                      warning ("`>=' comparison against empty string is always `True'");
                      return boolean_true_node;
                    }
                  else
                    {
                      warning ("`<' comparison against empty string is always `False'");
                      return boolean_false_node;
                    }
                }
              comp_empty = val;
            }
          if (comp_empty)
            {
              /* Now we only have to compare the length against 0.
                 The following code was roughly taken from the p_LENGTH case. */
              rts_inline = 1;
              rval = boolean_type_node;
              if (is_string_compatible_type (comp_empty, 1))
                retval = build_pascal_binary_op (invertresult ? NE_EXPR : EQ_EXPR, integer_zero_node,
                           convert (integer_type_node, PASCAL_STRING_LENGTH (comp_empty)));
              else
                errstr = "argument to `%s' must be a string or char";
              break;
            }
        }
#endif

      if (invertresult)
        post_operator = TRUTH_NOT_EXPR;

#if 0 /* This would be right, but causes some 226's. When they're fixed
         (on the level of `if' etc. rather than here), this should work,
         together with the corresponding change in rts/string.pas */
      fpar = chainon_const_string_schema (ptype_const_string_schema);
#else
      {
      tree arg1, len1, arg2, len2;
      if (TREE_CODE (base_type (TREE_TYPE (val))) == CHAR_TYPE)
        {
          /* kluuuuuudge */
          arg1 = convert (integer_type_node, val);
          len1 = build_int_2 (-1, -1);
          fpar = do_ptype (integer_type_node, 0, 0);
        }
      else
        {
          arg1 = build1 (ADDR_EXPR, string_type_node, PASCAL_STRING_VALUE (val));
          len1 = PASCAL_STRING_LENGTH (val);
          fpar = do_ptype (ptr_type_node, 0, 0);
        }
      fpar = chainon (fpar, do_ptype (integer_type_node, 0, 0));
      if (TREE_CODE (base_type (TREE_TYPE (val2))) == CHAR_TYPE)
        {
          /* kluuuuuudge */
          arg2 = convert (integer_type_node, val2);
          len2 = build_int_2 (-1, -1);
          fpar = chainon (fpar, do_ptype (integer_type_node, 0, 0));
        }
      else
        {
          arg2 = build1 (ADDR_EXPR, string_type_node, PASCAL_STRING_VALUE (val2));
          len2 = PASCAL_STRING_LENGTH (val2);
          fpar = chainon (fpar, do_ptype (ptr_type_node, 0, 0));
        }
      fpar = chainon (fpar, do_ptype (integer_type_node, 0, 0));
      apar = chainon (tree_cons (NULL_TREE, arg1, NULL_TREE),
             chainon (build_tree_list (NULL_TREE, len1),
             chainon (build_tree_list (NULL_TREE, arg2),
                      build_tree_list (NULL_TREE, len2))));
      }
#endif
      break;
    }

  case LEX_IS:
    fpar = chainon_pointer (ptype_pointer);
    rval = boolean_type_node;
    break;

  /* @@ Don't expand it because it's used in a COMPOUND_EXPR in
        build_is_as(). In the future, build_rts_call should not
        expand anything at all, and this special case can vanish. */
  case LEX_AS:
    fpar = ptype_void;
    return rts_call (rts_id, rval, fpar, apar);

  default:
    assert (0);

  }  /* The big `switch' statement ends here. */

  if (errstr)
    {
      error (errstr, rts_name);
      return error_mark_node;
    }

  /* Output an RTL line note. */
  emit_line_note (input_filename, lineno);

  /* Construct a call to the RTS if not compiled inline. */
  if (! rts_inline)
    retval = rts_call (rts_id, rval, fpar, apar);

  /* If this is a statement, built rtl from it,
   * otherwise let the caller do whatever it likes to do with it.
   */
  if (TREE_CODE (rval) == VOID_TYPE)
    {
      /* If we need to return something, like a string written
       * by an RTS procedure (acting as a function)
       */
      if (actual_return_value)
        {
          retval = build (COMPOUND_EXPR, TREE_TYPE (actual_return_value),
                          retval, actual_return_value);
          if (!actual_return_value_lvalue)
            retval = non_lvalue (retval);
        }
      else
        expand_expr_stmt (retval);
    }

  if (post_conversion)
    retval = convert (post_conversion, retval);

  if (post_operator)
    retval = build_pascal_unary_op (post_operator, retval, 0);

  if (post_statement)
    expand_expr_stmt (post_statement);

  /* Un-initialize at run-time the node in un_init_this. */
  if (un_init_this)
    init_any (un_init_this, 1);

  return retval;
}

/* File I/O. */

/* func is the RTS function to call (must return a pointer to the buffer)
 *
 * Because of lazy I/O, each buffer access needs to check
 * that the buffer is valid. If not, we need to do a get before
 * accessing the buffer.
 *
 * Lazy I/O helps to overcome the biggest problem of Pascal:
 * It's I/O system.
 *
 * When we do a reset or read something from a file, the old method
 * needs to read new contents to the buffer before the data is
 * actually needeed. This is annoying if you do interactive programs,
 * the output to terminal asking for input comes after you have
 * already given the input to the program, or then you have to code
 * things differently for terminals and files, which is also annoying.
 *
 * The old method GPC uses is the same implementation dependent feature
 * that the Pax compiler uses. The RTS checks each file whenit's reset,
 * and if it's a terminal, it sets EOLn implicitly on and places a space
 * in the file buffer. This is valid according to the standard, since it
 * explicitly states that handling of INPUT and OUTPUT is implementation
 * dependent.
 *
 * Lazy I/O means that we must do a PUT as early as we can, and GET as
 * late as we can. The first condition is satisfied either by not
 * buffering output at all, or then flushing output to terminals
 * before each get; the second condition is fulfilled when we check
 * that the buffer is valid each time we generate buffer references.
 */
tree
build_buffer_ref (file, func)
     tree file; int func;
{
  tree ft = TREE_TYPE (file);  /* type of variable */
  if (TREE_CODE (ft) == FILE_TYPE)
    {
      tree ref, t = TREE_TYPE (ft);  /* type of file component */
      tree ptr_type = build_pointer_type (t);
      ref = build1 (INDIRECT_REF, TYPE_MAIN_VARIANT (t),
              save_expr (
                rts_call (func, ptr_type,
                          do_ptype (TREE_TYPE (file), 1, 0),
                          build_tree_list (NULL_TREE, file))));
      TREE_READONLY (ref) = TREE_READONLY (t);
      TYPE_VOLATILE (ref) = TYPE_VOLATILE (t) || TYPE_VOLATILE (file);
      TREE_THIS_VOLATILE (ref) = TYPE_VOLATILE (t);
      init_any (ref, 0);
      return ref;
    }
  else if (file != error_mark_node && ft != error_mark_node)
    error ("file buffer referencing requires a file type argument");
  return error_mark_node;
}

/* Return standard input/output node of current module.
 * If not found, return global_in/output_file_node and warn
 * about ISO violation. Never return NULL.
 */
tree
get_standard_input ()
{
  if (!current_module->input_file_node)
    {
      current_module->input_file_node = global_input_file_node;
      if (PEDANTIC (U_B_D_PASCAL))
        {
          if (current_module->main_program)
            error ("file `Input' was not mentioned in program header");
          else
            error ("`StandardInput' not imported by module");
        }
    }
  return current_module->input_file_node;
}

tree
get_standard_output ()
{
  if (!current_module->output_file_node)
    {
      current_module->output_file_node = global_output_file_node;
      if (PEDANTIC (U_B_D_PASCAL))
        {
          if (current_module->main_program)
            error ("file `Output' was not mentioned in program header");
          else
            error ("`StandardOutput' not imported by module");
        }
    }
  return current_module->output_file_node;
}

tree
get_standard_error ()
{
  if (!current_module->error_file_node)
    {
      current_module->error_file_node = global_error_file_node;
      if (PEDANTIC (U_B_D_PASCAL))
        {
          if (current_module->main_program)
            error ("file `StdErr' was not mentioned in program header");
          else
            error ("`StandardError' not imported by module");
        }
    }
  return current_module->error_file_node;
}

tree
get_builtin_variable (name, type)
     char *name;
     tree type;
{
  tree id = get_identifier (name);
  tree var = lookup_name (id);
  if (var == NULL_TREE)
    {
      declare_vars (build_tree_list (NULL_TREE, id), type, NULL_TREE,
                    NULL_PTR, VQ_EXTERNAL, 0, NULL_TREE);
      var = lookup_name (id);
      TREE_USED (var) = 1;
    }
  return var;
}
