parser.c

/* Copyright 2009-2025
 * Kaz Kylheku <kaz@kylheku.com>
 * Vancouver, Canada
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * 1. Redistributions of source code must retain the above copyright notice,
 *    this list of conditions and the following disclaimer.
 *
 * 2. Redistributions in binary form must reproduce the above copyright notice,
 *    this list of conditions and the following disclaimer in the documentation
 *    and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 */

#include <stdio.h>
#include <assert.h>
#include <limits.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <wchar.h>
#include <signal.h>
#include <wctype.h>
#include <errno.h>
#include "config.h"
#include "alloca.h"
#ifdef __CYGWIN__
#include <sys/utsname.h>
#endif
#if HAVE_SYS_STAT
#include <sys/stat.h>
#endif
#if HAVE_ZLIB
#include <zlib.h>
#endif
#include "lib.h"
#include "signal.h"
#include "unwind.h"
#include "gc.h"
#include "args.h"
#include "utf8.h"
#include "hash.h"
#include "eval.h"
#define STREAM_IMPL
#include "stream.h"
#if HAVE_ZLIB
#include "gzio.h"
#endif
#include "y.tab.h"
#include "sysif.h"
#include "cadr.h"
#include "struct.h"
#include "tree.h"
#include "parser.h"
#include "regex.h"
#include "itypes.h"
#include "arith.h"
#include "buf.h"
#include "vm.h"
#include "ffi.h"
#include "txr.h"
#include "linenoise/linenoise.h"

#define SHADOW_TAB_SIZE 16

#define min(a, b) ((a) < (b) ? (a) : (b))

val parser_s, unique_s, circref_s;
val listener_hist_len_s, listener_multi_line_p_s, listener_sel_inclusive_p_s;
val listener_pprint_s, listener_greedy_eval_s, listener_auto_compound_s;
val listener_auto_infix_s, listener_ignore_eof_s;
val rec_source_loc_s, read_unknown_structs_s, read_bad_json_s, read_json_int_s;
val json_s;
val intr_s;

struct cobj_class *parser_cls;

static lino_t *lino_ctx;
static int repl_level = 0;

static val stream_parser_hash, catch_all, catch_error;

static struct shadow_ops_map {
  struct strm_ops *from, *to;
} shadow_tab[SHADOW_TAB_SIZE];

static void yy_tok_mark(struct yy_token *tok)
{
  gc_conservative_mark(tok->yy_lval.val);
}

static void parser_mark(val obj)
{
  int i;
  parser_t *p = coerce(parser_t *, obj->co.handle);

  assert (p->parser == nil || p->parser == obj);
  gc_mark(p->stream);
  gc_mark(p->name);
  gc_mark(p->prepared_msg);
  gc_mark(p->circ_ref_hash);
  if (p->syntax_tree != nao)
    gc_mark(p->syntax_tree);
  yy_tok_mark(&p->recent_tok);
  for (i = 0; i < 4; i++)
    yy_tok_mark(&p->tok_pushback[i]);
}

static void parser_destroy(val obj)
{
  parser_t *p = coerce(parser_t *, obj->co.handle);
  parser_cleanup(p);
  free(p);
}

static struct cobj_ops parser_ops = cobj_ops_init(eq,
                                                  cobj_print_op,
                                                  parser_destroy,
                                                  parser_mark,
                                                  cobj_eq_hash_op,
                                                  0);

void parser_common_init(parser_t *p)
{
  int i;
  yyscan_t yyscan;
  val rec_source_loc_var = lookup_var(nil, rec_source_loc_s);
  val read_unknown_structs_var = lookup_var(nil, read_unknown_structs_s);
  val read_bad_json_var = lookup_var(nil, read_bad_json_s);
  val read_json_int = lookup_var(nil, read_json_int_s);

  p->parser = nil;
  p->lineno = 1;
  p->errors = 0;
  p->eof = 0;
  p->ignore = 0;
  p->stream = nil;
  p->name = nil;
  p->prepared_msg = nil;
  p->circ_ref_hash = nil;
  p->circ_count = 0;
  p->syntax_tree = nil;
  p->quasi_level = 0;
  yylex_init(&yyscan);
  p->scanner = convert(scanner_t *, yyscan);
  yyset_extra(p, p->scanner);
  p->recent_tok.yy_char = 0;
  p->recent_tok.yy_lex_state = 0;
  p->recent_tok.yy_lval.val = 0;
  for (i = 0; i < 4; i++) {
    p->tok_pushback[i].yy_char = 0;
    p->tok_pushback[i].yy_lex_state = 0;
    p->tok_pushback[i].yy_lval.val = 0;
  }
  p->tok_idx = 0;
  p->rec_source_loc = !nilp(cdr(rec_source_loc_var));
  p->json_quote_char = 0;
  p->read_unknown_structs = !nilp(cdr(read_unknown_structs_var));
  p->read_bad_json = !nilp(cdr(read_bad_json_var));
  p->read_json_int = !nilp(cdr(read_json_int));
}

void parser_cleanup(parser_t *p)
{
  if (p->scanner != 0)
    yylex_destroy(p->scanner);
  p->scanner = 0;
}

void parser_reset(parser_t *p)
{
  yyscan_t yyscan;
  parser_cleanup(p);
  yylex_init(&yyscan);
  p->scanner = convert(scanner_t *, yyscan);
  yyset_extra(p, p->scanner);
}

val parser(val stream, val name, val lineno)
{
  val self = lit("parser");
  parser_t *p = coerce(parser_t *, chk_malloc(sizeof *p));
  val parser;
  parser_common_init(p);
  parser = cobj(coerce(mem_t *, p), parser_cls, &parser_ops);
  p->parser = parser;
  p->lineno = c_num(default_arg(lineno, one), self);
  p->name = name;
  p->stream = stream;

  return parser;
}

parser_t *parser_get_impl(val self, val parser)
{
  return coerce(parser_t *, cobj_handle(self, parser, parser_cls));
}

val ensure_parser(val stream, val name)
{
  uses_or2;
  loc pcdr = gethash_l(lit("internal error"), stream_parser_hash, stream, nulloc);
  val pars = deref(pcdr);
  if (pars)
    return pars;
  return set(pcdr,
             parser(stream, or2(name, stream_get_prop(stream, name_k)), one));
}

static void pushback_token(parser_t *p, struct yy_token *tok)
{
  assert (p->tok_idx < 4);
  p->tok_pushback[p->tok_idx++] = *tok;
}

val parser_set_lineno(val self, val stream, val lineno)
{
  val parser = ensure_parser(stream, nil);
  parser_t *pi = parser_get_impl(self, parser);
  pi->lineno = c_num(lineno, self);
  return stream;
}

void prime_parser(parser_t *p, val name, enum prime_parser prim)
{
  struct yy_token sec_tok = all_zero_init;

  switch (prim) {
  case prime_lisp:
    sec_tok.yy_char = SECRET_ESCAPE_E;
    break;
  case prime_interactive:
    sec_tok.yy_char = SECRET_ESCAPE_I;
    break;
  case prime_regex:
    sec_tok.yy_char = SECRET_ESCAPE_R;
    break;
  case prime_json:
    sec_tok.yy_char = SECRET_ESCAPE_J;
    break;
  }

  if (p->recent_tok.yy_char && prim != prime_json)
    pushback_token(p, &p->recent_tok);
  pushback_token(p, &sec_tok);
  prime_scanner(p->scanner, prim);
  set(mkloc(p->name, p->parser), name);
}

void prime_parser_post(parser_t *p, enum prime_parser prim)
{
  p->eof = (p->recent_tok.yy_char == 0);
  if (prim == prime_interactive || prim == prime_json)
    p->recent_tok.yy_char = 0;
}

int parser_callgraph_circ_check(struct circ_stack *rs, val obj)
{
  for (; rs; rs = rs->up) {
    if (rs->obj == obj)
      return 0;
  }

  return 1;
}

static val patch_ref(parser_t *p, val obj)
{
  if (consp(obj)) {
    val a = pop(&obj);
    if (a == circref_s) {
      val num = car(obj);
      val rep = gethash(p->circ_ref_hash, num);
      if (!rep)
        yyerrorf(p->scanner, lit("dangling #~s# ref"), num, nao);
      if (consp(rep) && car(rep) == circref_s)
        yyerrorf(p->scanner, lit("absurd #~s# ref"), num, nao);
      if (!p->circ_count--)
        yyerrorf(p->scanner, lit("unexpected surplus #~s# ref"), num, nao);
      return rep;
    }
  }
  return nil;
}

static void circ_backpatch(parser_t *p, struct circ_stack *up, val obj)
{
  val self = lit("parser");
  struct circ_stack cs = { up, obj };

  if (!parser_callgraph_circ_check(up, obj))
    return;

tail:
  if (!p->circ_count)
    return;
  if (!is_ptr(obj))
    return;
  switch (type(obj)) {
  case CONS:
    {
      us_cons_bind(a, d, obj);
      val ra = patch_ref(p, a);
      val rd = patch_ref(p, d);

      if (ra)
        us_rplaca(obj, ra);
      else
        circ_backpatch(p, &cs, a);

      if (rd) {
        us_rplacd(obj, rd);
        break;
      }

      obj = d;
      goto tail;
    }
  case VEC:
    {
      cnum i;
      cnum l = c_num(length_vec(obj), self);

      for (i = 0; i < l; i++) {
        val v = obj->v.vec[i];
        val rv = patch_ref(p, v);
        if (rv)
          set(mkloc(obj->v.vec[i], obj), rv);
        else
          circ_backpatch(p, &cs, v);
        if (!p->circ_count)
          break;
      }

      break;
    }
  case RNG:
    {
      val s = from(obj);
      val e = to(obj);
      val rs = patch_ref(p, s);
      val re = patch_ref(p, e);

      if (rs)
        set_from(obj, rs);
      else
        circ_backpatch(p, &cs, s);

      if (re) {
        set_to(obj, re);
        break;
      }

      obj = e;
      goto tail;
    }
  case TNOD:
    {
      val k = obj->tn.key;
      val l = obj->tn.left;
      val r = obj->tn.right;
      val rk = patch_ref(p, k);
      val rl = patch_ref(p, l);
      val rr = patch_ref(p, r);

      if (rl)
        set(mkloc(obj->tn.left, obj), rl);
      else
        circ_backpatch(p, &cs, l);

      if (rr)
        set(mkloc(obj->tn.right, obj), rr);
      else
        circ_backpatch(p, &cs, r);

      if (rk)
        set(mkloc(obj->tn.key, obj), rk);

      obj = k;
      goto tail;
    }
  case COBJ:
    if (hashp(obj)) {
      val u = get_hash_userdata(obj);
      val ru = patch_ref(p, u);
      cnum old_circ_count = p->circ_count;

      if (ru)
        set_hash_userdata(obj, ru);
      else
        circ_backpatch(p, &cs, u);

      if (old_circ_count > 0) {
        val cell;
        val pairs = nil;
        struct hash_iter hi;

        us_hash_iter_init(&hi, obj);

        while ((cell = hash_iter_next(&hi))) {
          circ_backpatch(p, &cs, cell);
          push(cell, &pairs);
        }

        if (old_circ_count != p->circ_count) {
          clearhash(obj);

          while (pairs) {
            val cell = rcyc_pop(&pairs);
            sethash(obj, us_car(cell), us_cdr(cell));
          }
        } else {
          while (pairs)
            rcyc_pop(&pairs);
        }
      }
    } else if (structp(obj)) {
      val stype = struct_type(obj);
      val iter;

      for (iter = slots(stype); iter; iter = cdr(iter)) {
        val sn = car(iter);
        val sv = slot(obj, sn);
        val rsv = patch_ref(p, sv);
        if (rsv)
          slotset(obj, sn, rsv);
        else
          circ_backpatch(p, &cs, sv);
        if (p->circ_count <= 0)
          break;
      }
    } else if (treep(obj)) {
      val iter = tree_begin(obj, colon_k, colon_k);
      val node;
      val nodes = nil;
      cnum old_circ_count = p->circ_count;

      while ((node = tree_next(iter))) {
        val k = node->tn.key;
        val rk = patch_ref(p, k);
        if (rk)
          set(mkloc(node->tn.key, node), rk);
        else
          circ_backpatch(p, &cs, k);
        push(node, &nodes);
      }

      if (nodes && old_circ_count != p->circ_count) {
        tree_clear(obj);

        while (nodes) {
          val node = rcyc_pop(&nodes);
          tree_insert_node(obj, node, t);
        }
      } else {
        while (nodes)
          rcyc_pop(&nodes);
      }
    }

    break;
  case FUN:
    if (obj->f.functype == FINTERP) {
      val fun = obj->f.f.interp_fun;
      circ_backpatch(p, &cs, car(fun));
      obj = cadr(fun);
      goto tail;
    }
  default:
    break;
  }
  return;
}

void parser_resolve_circ(parser_t *p)
{
  if (p->circ_count == 0)
    return;


  circ_backpatch(p, 0, p->syntax_tree);

  if (p->circ_count > 0)
    yyerrorf(p->scanner, lit("not all #<num># refs replaced in object ~s"),
             p->syntax_tree, nao);
}

void parser_circ_def(parser_t *p, val num, val expr)
{
  if (!p->circ_ref_hash) {
    p->circ_ref_hash = make_eq_hash(hash_weak_none);
    setcheck(p->parser, p->circ_ref_hash);
  }

  {
    val new_p = nil;
    loc pcdr = gethash_l(lit("parser"), p->circ_ref_hash, num, mkcloc(new_p));

    if (!new_p && deref(pcdr) != unique_s)
      yyerrorf(p->scanner, lit("duplicate #~s= def"), num, nao);

    set(pcdr, expr);
  }
}

val parser_circ_ref(parser_t *p, val num)
{
  val obj = if2(p->circ_ref_hash, gethash(p->circ_ref_hash, num));

  if (!obj)
    yyerrorf(p->scanner, lit("dangling #~s# ref"), num, nao);

  if (obj == unique_s && !p->ignore) {
    p->circ_count++;
    return cons(circref_s, cons(num, nil));
  }

  return obj;
}

void open_txr_file(val first_try_path, val *txr_lisp_p,
                   val *orig_in_resolved_out, val *stream,
                   val search_dirs, val self)
{
  enum { none, tl, tlo, tlz, txr } suffix;
#if HAVE_ZLIB
  struct stdio_mode m_r = stdio_mode_init_r;
#endif

  if (match_str(first_try_path, lit(".txr"), negone))
    suffix = txr;
  else if (match_str(first_try_path, lit(".tl"), negone))
    suffix = tl;
  else if (match_str(first_try_path, lit(".tlo"), negone))
    suffix = tlo;
  else if (match_str(first_try_path, lit(".tlo.gz"), negone))
    suffix = tlz;
  else if (match_str(first_try_path, lit(".txr-profile"), negone))
    suffix = tl;
  else if (match_str(first_try_path, lit(".txr_profile"), negone))
    suffix = tl;
  else
    suffix = none;

#if !HAVE_ZLIB
  if (suffix == tlz)
    uw_ethrowf(file_error_s, lit("~s: cannot open ~s files: "
                                 "not built with zlib support"),
               self, nao);
#endif

  errno = 0;

  {
    val try_path = nil;
    FILE *in = 0;
#if HAVE_ZLIB
    gzFile zin = 0;
#else
    const int zin = 0;
#endif

    {
      try_path = first_try_path;
      errno = 0;
#if HAVE_ZLIB
      if (suffix == tlz)
        zin = w_gzopen_mode(c_str(try_path, self), L"r", m_r, self);
      else
#endif
        in = w_fopen(c_str(try_path, self), L"r");

      if (in != 0 || zin != 0) {
        switch (suffix) {
        case tl:
          *txr_lisp_p = t;
          break;
        case tlo: case tlz:
          *txr_lisp_p = chr('o');
          break;
        case txr:
          *txr_lisp_p = nil;
          break;
        default:
          break;
        }
        goto found;
       } else {
#ifdef ENOENT
        if (errno != ENOENT)
          goto except;
#endif
       }
    }

    if (suffix == none && !*txr_lisp_p) {
      try_path = scat(lit("."), first_try_path, lit("txr"), nao);
      if ((in = w_fopen(c_str(try_path, nil), L"r")) != 0)
        goto found;
#ifdef ENOENT
      if (errno != ENOENT)
        goto except;
#endif
    }

    if (suffix == none) {
      {
        try_path = scat(lit("."), first_try_path, lit("tlo"), nao);
        errno = 0;
        if ((in = w_fopen(c_str(try_path, nil), L"r")) != 0) {
          *txr_lisp_p = chr('o');
          goto found;
        }
#ifdef ENOENT
        if (errno != ENOENT)
          goto except;
#endif
      }
#if HAVE_ZLIB
      {
        try_path = scat(lit("."), first_try_path, lit("tlo.gz"), nao);
        errno = 0;
        if ((zin = w_gzopen_mode(c_str(try_path, nil), L"r", m_r, self)) != 0) {
          *txr_lisp_p = chr('o');
          goto found;
        }
#ifdef ENOENT
        if (errno != ENOENT)
          goto except;
#endif
      }
#endif
      {
        try_path = scat(lit("."), first_try_path, lit("tl"), nao);
        errno = 0;
        if ((in = w_fopen(c_str(try_path, nil), L"r")) != 0) {
          *txr_lisp_p = t;
          goto found;
        }
#ifdef ENOENT
        if (errno != ENOENT)
          goto except;
#endif
      }
    }

    if (in == 0 && zin == 0) {
      val try_next;
#ifdef ENOENT
except:
#endif
      if (abs_path_p(*orig_in_resolved_out))
        search_dirs = nil;
      else if (search_dirs == t)
        search_dirs = load_search_dirs;

#ifdef  ENOENT
      if (errno != ENOENT || search_dirs == nil)
#else
      if (search_dirs == nil)
#endif
        uw_ethrowf(errno_to_file_error(errno),
                   lit("~a: unable to open ~a"), self, *orig_in_resolved_out, nao);
      try_next = path_cat(pop(&search_dirs), *orig_in_resolved_out);
      open_txr_file(try_next, txr_lisp_p, orig_in_resolved_out, stream,
                    search_dirs, self);
      return;
    }

found:
    if (in != 0)
      *stream = make_stdio_stream(in, try_path);
#if HAVE_ZLIB
    else
      *stream = make_gzio_stream(zin, -1, try_path, 0);
#endif
    *orig_in_resolved_out = try_path;
  }
}

val regex_parse(val string, val error_stream)
{
  val save_stream = std_error;
  val stream = make_string_byte_input_stream(string);
  parser_t parser;

  error_stream = default_arg_strict(error_stream, std_null);
  std_error = if3(error_stream == t, std_output, error_stream);

  parser_common_init(&parser);
  parser.stream = stream;

  {
    int gc = gc_state(0);
    parse(&parser, if3(std_error != std_null, lit("regex"), null_string),
          prime_regex);
    gc_state(gc);
  }

  parser_cleanup(&parser);
  std_error = save_stream;

  if (parser.errors)
    uw_throw(syntax_error_s, lit("regex-parse: syntax errors in regex"));

  return parser.syntax_tree;
}

static val lisp_parse_impl(val self, enum prime_parser prime,
                           val rlcp_p, val source_in,
                           val error_stream, val error_return_val, val name_in,
                           val lineno)
{
  val source = default_arg_strict(source_in, std_input);
  val str = stringp(source);
  val input_stream = if3(str, make_string_byte_input_stream(source), source);
  val name = default_arg_strict(name_in,
                                if3(str,
                                    lit("string"),
                                    stream_get_prop(input_stream, name_k)));
  val parser = ensure_parser(input_stream, name);
  val saved_dyn = dyn_env;
  parser_t *pi = parser_get_impl(self, parser);
  volatile val parsed = nil;

  if (rlcp_p)
    pi->rec_source_loc = 1;

  uw_simple_catch_begin;

  dyn_env = make_env(nil, nil, dyn_env);

  error_stream = default_arg_strict(error_stream, std_null);
  error_stream = if3(error_stream == t, std_output, error_stream);
  class_check (self, error_stream, stream_cls);

  if (lineno && !missingp(lineno))
    pi->lineno = c_num(lineno, self);

  env_vbind(dyn_env, stderr_s, error_stream);

  for (;;) {
    int gc = gc_state(0);
    parse(pi, if3(std_error != std_null, name, null_string), prime);
    mut(parser);
    gc_state(gc);
    parser_shadow_stream_attach(self, input_stream);

    if (pi->syntax_tree == nao && pi->errors == 0 && !pi->eof)
      continue;

    break;
  }

  if (str) {
    int junk = 0;
    if (prime == prime_json) {
      YYSTYPE yyl;
      junk = yylex(&yyl, pi->scanner);
    } else {
      junk = pi->recent_tok.yy_char;
    }

    if (junk)
      yyerrorf(pi->scanner, lit("trailing material after expression"), nao);
  }

  parsed = t;

  uw_unwind {
    dyn_env = saved_dyn;
    if (!parsed) {
      parser_reset(pi);
    }
  }

  uw_catch_end;

  if (pi->errors || pi->syntax_tree == nao) {
    if (missingp(error_return_val))
      uw_throwf(syntax_error_s, lit("read: ~a: ~a"), name,
                if3(pi->syntax_tree == nao,
                    lit("end of input reached without seeing object"),
                    lit("errors encountered")), nao);
    return error_return_val;
  }

  gc_hint(parser);

  return pi->syntax_tree;
}

val lisp_parse(val source_in, val error_stream, val error_return_val,
               val name_in, val lineno)
{
  val self = lit("lisp-parse");
  return lisp_parse_impl(self, prime_lisp, t, source_in, error_stream,
                         error_return_val, name_in, lineno);
}

val nread(val source_in, val error_stream, val error_return_val,
          val name_in, val lineno)
{
  val self = lit("nread");
  return lisp_parse_impl(self, prime_lisp, nil, source_in, error_stream,
                         error_return_val, name_in, lineno);
}

val iread(val source_in, val error_stream, val error_return_val,
          val name_in, val lineno)
{
  val self = lit("iread");
  return lisp_parse_impl(self, prime_interactive, nil, source_in, error_stream,
                         error_return_val, name_in, lineno);
}

val get_json(val source_in, val error_stream, val error_return_val,
             val name_in, val lineno)
{
  val self = lit("get-json");
  return lisp_parse_impl(self, prime_json, nil, source_in, error_stream,
                         error_return_val, name_in, lineno);
}

static val read_file_common(val self, val stream, val error_stream, val compiled)
{
  val error_val = gensym(nil);
  val name = stream_get_prop(stream, name_k);
  val first = t;
  val big_endian = nil;
  val parser = ensure_parser(stream, name);
  val not_compiled = null(compiled);
  val version_form = nil;

  if (compiled) {
    parser_t *pi = parser_get_impl(self, parser);
    pi->rec_source_loc = 0;
  }

  for (;;) {
    val form = lisp_parse_impl(self, prime_lisp, not_compiled, stream,
                               error_stream, error_val, name, colon_k);

    if (form == error_val) {
      if (parser_errors(parser) != zero)
        return nil;
      break;
    }

    if (compiled && first) {
      val major = car(form);
      val minor = cadr(form);

      if (lt(major, num_fast(6)) || gt(major, num_fast(8)) ||
          (major == num_fast(8) && gt(minor, one)))
      {
        uw_throwf(error_s,
                  lit("cannot load ~s: version number mismatch"),
                  stream, nao);
      }

      big_endian = caddr(form);
      first = nil;
      version_form = form;
    } else if (compiled) {
      if (consp(car(form))) {
        for (; form; form = cdr(form)) {
          val item = car(form);
          val nlevels = pop(&item);
          val nregs = pop(&item);
          val bytecode = pop(&item);
          val datavec = pop(&item);
          val funvec = car(item);
          val desc = vm_make_desc(nlevels, nregs, bytecode, datavec, funvec);
          if ((big_endian && HAVE_LITTLE_ENDIAN) ||
              (!big_endian && !HAVE_LITTLE_ENDIAN))
            buf_swap32(bytecode);
          (void) vm_execute_toplevel(desc);
          gc_hint(desc);
        }
      } else if (nequal(form, version_form)) {
        uw_throwf(error_s, lit("~s: mismatched version ~s in combined .tlo file"),
                  stream, form, nao);
      }
    } else {
      (void) eval_intrinsic(form, nil, nil);
    }
  }

  return t;
}

val read_eval_stream(val self, val stream, val error_stream)
{
  return read_file_common(self, stream, error_stream, nil);
}

val read_compiled_file(val self, val stream, val error_stream)
{
  return read_file_common(self, stream, error_stream, t);
}

static val read_objects_common(val stream, val error_stream_in,
                               val error_return_val, val name,
                               val lineno, val self)
{
  val error_stream = if3(error_stream_in == t,
                         std_output,
                         default_arg_strict(error_stream_in, std_null));
  val parser = ensure_parser(stream, name);
  parser_t *pi = parser_get_impl(self, parser);
  list_collect_decl (out, ptail);

  if (lineno && !missingp(lineno))
    pi->lineno = c_num(lineno, self);

  for (;;) {
    val form = lisp_parse_impl(self, prime_lisp, t, stream,
                               error_stream, unique_s, name, colon_k);

    if (form == unique_s) {
      if (pi->errors) {
        if (missingp(error_return_val))
          uw_throwf(syntax_error_s, lit("read: ~a: errors encountered"),
                    name, nao);
        return error_return_val;
      }
      break;
    }

    ptail = list_collect(ptail, form);
  }

  return out;
}

val read_objects_from_string(val string, val error_stream,
                             val error_return_val, val name_in)
{
  val self = lit("read-objects-from-string");
  val stream = make_string_byte_input_stream(string);
  val name = default_arg(name_in, lit("string"));

  return read_objects_common(stream, error_stream, error_return_val,
                             name, one, self);
}

val read_objects(val source_in, val error_stream, val error_return_val,
                 val name_in, val lineno_in)
{
  val self = lit("read-objects");
  val source = default_arg_strict(source_in, std_input);
  val str = stringp(source);
  val input_stream = if3(str, make_string_byte_input_stream(source), source);
  val name = default_arg_strict(name_in,
                                if3(str,
                                    lit("string"),
                                    stream_get_prop(input_stream, name_k)));
  return read_objects_common(input_stream, error_stream, error_return_val,
                             name, lineno_in, self);
}

val txr_parse(val source_in, val error_stream,
              val error_return_val, val name_in)
{
  val self = lit("txr-parse");
  val source = default_arg_strict(source_in, std_input);
  val input_stream = if3(stringp(source),
                         make_string_byte_input_stream(source),
                         source);
  val name = default_arg_strict(name_in,
                                if3(stringp(source),
                                    lit("string"),
                                    stream_get_prop(input_stream, name_k)));
  int gc = gc_state(0);
  val saved_dyn = dyn_env;
  val parser_obj = ensure_parser(input_stream, name);
  parser_t *pi = parser_get_impl(self, parser_obj);
  val loading = cdr(lookup_var(nil, load_recursive_s));

  uw_simple_catch_begin;

  dyn_env = make_env(nil, nil, dyn_env);
  error_stream = default_arg_strict(error_stream, std_null);
  error_stream = if3(error_stream == t, std_output, error_stream);
  class_check (self, error_stream, stream_cls);

  parse_once(self, input_stream, name);

  uw_unwind {
    dyn_env = saved_dyn;
    mut(parser_obj);
    gc_state(gc);
    if (!loading)
      uw_release_deferred_warnings();
  }

  uw_catch_end;

  if (pi->errors || pi->syntax_tree == nao) {
    if (missingp(error_return_val))
      uw_throwf(syntax_error_s, lit("~a: ~a: ~a"), self, name,
                if3(pi->syntax_tree == nao,
                    lit("end of input reached without seeing object"),
                    lit("errors encountered")), nao);

    return error_return_val;
  }

  return pi->syntax_tree;
}

static void report_file_perm_problem(val name)
{
#ifdef __CYGWIN__
  (void) name;
#else
  format(std_output,
         lit("** security problem: ~a is readable by others\n"),
         name, nao);
#endif
}

static void report_path_perm_problem(val name)
{
#ifdef __CYGWIN__
  (void) name;
#else
  format(std_output,
         lit("** security problem: a component of ~a is writable to others\n"),
         name, nao);
#endif
}

static void load_rcfile(val home, val pexist_s, val psafe_s, val ppriv_s)
{
  val self = lit("listener");
  val lisp_p = t;
  val stream = nil;
  val try1 = scat2(home, lit("/.txr-profile"));
  val try2 = scat2(home, lit("/.txr_profile"));

  val name = if3(funcall1(pexist_s, try1), try1,
                 if2(funcall1(pexist_s, try2), try2));
  val resolved_name = name;

  if (!name)
    return;

  if (!funcall1(psafe_s, name)) {
    report_path_perm_problem(name);
    return;
  }

  uw_catch_begin (catch_error, sy, va);

  open_txr_file(name, &lisp_p, &resolved_name, &stream, nil, self);

  if (stream) {
    if (!funcall1(ppriv_s, stream)) {
      report_file_perm_problem(name);
    } else {
      val saved_dyn_env = set_dyn_env(make_env(nil, nil, dyn_env));
      env_vbind(dyn_env, load_path_s, resolved_name);
      read_eval_stream(self, stream, std_output);
      dyn_env = saved_dyn_env;
    }
  }

  uw_catch(sy, va)
  {
    (void) va;
    if (stream || sy != path_not_found_s) {
      format(std_output, lit("** type ~s exception while loading ~a\n"),
             sy, name, nao);
      format(std_output, lit("** details: ~a\n"), car(va), nao);
    }
  }

  uw_unwind {
    if (stream)
      close_stream(stream, nil);
  }

  uw_catch_end;
}

#if CONFIG_FULL_REPL

static val get_visible_syms(val package, int include_fallback)
{
  val fblist;

  if (!include_fallback || nilp((fblist = package_fallback_list(package)))) {
    return package_symbols(package);
  } else {
    val symhash = copy_hash(package->pk.symhash);

    for (; fblist; fblist = cdr(fblist))
    {
      val fb_pkg = car(fblist);
      val fcell;
      val new_p;
      struct hash_iter hi;

      us_hash_iter_init(&hi, fb_pkg->pk.symhash);

      while ((fcell = hash_iter_next(&hi))) {
        loc pcdr = gethash_l(lit("listener"), symhash, us_car(fcell), mkcloc(new_p));
        if (new_p)
          set(pcdr, us_cdr(fcell));
      }
    }
    return hash_values(symhash);
  }
}

static void find_matching_syms(lino_completions_t *cpl,
                               val package, val prefix,
                               val line_prefix, char kind,
                               val force_qualify)
{
  val is_cur = tnil(package == cur_package);
  val qualify = tnil(force_qualify || !is_cur);
  val pkg_name = if2(qualify,
                     if3(package == keyword_package && !force_qualify,
                         null_string,
                         package_name(package)));
  val syms = get_visible_syms(package, is_cur != nil && !qualify);

  for ( ; syms; syms = cdr(syms)) {
    val sym = car(syms);
    val name = symbol_name(sym);
    val found = if3(cpl->substring,
                    search_str(name, prefix, zero, nil),
                    match_str(name, prefix, zero));

    if (found) {
      val comple;

      switch (kind) {
      case '(':
        if (fboundp(sym) || mboundp(sym) || special_operator_p(sym))
          break;
        continue;
      case 'M':
        if (static_slot_types(sym))
          break;
        continue;
      case 'S':
        if (slot_types(sym))
          break;
        continue;
        break;
      case 'Q':
        if (mboundp(sym) || special_operator_p(sym))
          break;
        /* fallthrough */
      default:
        if (keywordp(sym) || find_struct_type(sym) || ffi_type_p(sym))
          break;
        /* fallthrough */
      case '[':
        if (fboundp(sym) || boundp(sym))
          break;
        continue;
      }

      if (equal(name, prefix))
        continue;

      if (qualify)
        comple = scat(nil, line_prefix, pkg_name, lit(":"), name, nao);
      else
        comple = scat2(line_prefix, name);

      lino_add_completion(cpl, c_str(comple, nil));
      gc_hint(comple);
    }
  }
}

static void provide_completions(const wchar_t *data,
                                lino_completions_t *cpl,
                                void *ctx)
{
  const wchar_t *gly = L"!$%&*+-<=>?\\_~/";
  const wchar_t *ptr = data[0] ? data + wcslen(data) - 1 : 0;
  const wchar_t *sym = 0, *pkg = 0;
  const wchar_t *end;
  val keyword = nil;
  val package = nil;

  (void) ctx;

  uw_catch_begin (catch_error, exsym, exvals);

  if (!ptr)
    goto out;

  while ((iswalnum(convert(wint_t, *ptr)) || wcschr(gly, *ptr) ||
          *ptr >= 0x80) &&
         (sym = ptr) && ptr > data)
    ptr--;

  if (!sym)
    goto out;

  end = sym;

  if (*ptr == ':') {
    if (ptr == data) {
      keyword = t;
    } else {
      ptr--;

      while ((iswalnum(convert(wint_t, *ptr)) || wcschr(gly, *ptr) ||
              *ptr >= 0x80) &&
             (pkg = ptr) && ptr > data)
        ptr--;

      if (!pkg)
        keyword = t;
    }
  }

  if (keyword) {
    package = keyword_package;
    end = sym - 1;
  } else if (pkg) {
    size_t sz = sym - pkg;
    wchar_t *pkg_copy = convert(wchar_t *, alloca(sizeof *pkg_copy * sz));

    wmemcpy(pkg_copy, pkg, sz);
    pkg_copy[sz - 1] = 0;

    {
      val package_name = string(pkg_copy);
      package = find_package(package_name);
      if (!package)
        goto out;
    }

    end = pkg;
  }

  {
    val sym_pfx = string(sym);
    size_t lsz = end - data + 1;
    wchar_t *line_pfxs = convert(wchar_t *, alloca(sizeof *line_pfxs * lsz));
    wmemcpy(line_pfxs, data, lsz);
    line_pfxs[lsz - 1] = 0;

    {
      uses_or2;
      val line_pfx = string(line_pfxs);
      char prev = (end > data) ? end[-1] : 0;
      char pprev = (end > data + 1) ? end[-2] : 0;
      int quote = (prev == '^' || prev == '\'');
      int pquote = (pprev == '^' || pprev == '\'' || pprev == '#');
      int ppar = (pprev == '(');
      int dwim = (prev == '[');
      int par = (prev == '(');
      int slot = (prev == '.');
      int meth = (pprev == '.') && (dwim || par);
      char kind = if3(slot, 'S',
                      if3(meth, 'M',
                          if3(quote, 'Q',
                              if3(!pprev || (!pquote && !ppar) || dwim,
                                  prev,  0))));

      find_matching_syms(cpl, or2(package, cur_package),
                         sym_pfx, line_pfx, kind, if2(package, null(keyword)));
    }
  }

out:
  uw_catch (exsym, exvals) {
    (void) exsym;
    (void) exvals;
  }

  uw_unwind;

  uw_catch_end;
}

static wchar_t *provide_atom(lino_t *l, const wchar_t *str, int n, void *ctx)
{
  val obj = nao;
  val form;
  val line = string(str);
  wchar_t *out = 0;

  (void) l;
  (void) ctx;

  uw_catch_begin (catch_all, exsym, exvals);

  form = lisp_parse(line, std_null, colon_k, lit("atomcb"), colon_k);

  if (atom(form)) {
    if (n == 1)
      obj = form;
  } else {
    val fform = flatcar(form);
    obj = ref(fform, num(-n));
  }

  if (obj != nao)
    out = chk_strdup(c_str(tostring(obj), nil));

  uw_catch (exsym, exvals) {
    (void) exsym;
    (void) exvals;
  }

  uw_unwind;

  uw_catch_end;

  return out;
}

#endif

static val repl_intr(val signo, val async_p)
{
  (void) signo;
  (void) async_p;
  return uw_rthrow(intr_s, lit("intr"));
}

static val read_eval_ret_last(val env, val counter,
                              val in_stream, val out_stream)
{
  val lineno = one;
  val error_val = gensym(nil);
  val name = format(nil, lit("paste-~a"), counter, nao);
  val value = nil;
  val loading = cdr(lookup_var(nil, load_recursive_s));
  val saved_dyn_env = set_dyn_env(make_env(nil, nil, dyn_env));
  env_vbind(dyn_env, load_recursive_s, t);

  (void) env;

  for (;; lineno = succ(lineno)) {
    val form = lisp_parse(in_stream, out_stream, error_val, name, lineno);

    if (form == error_val)
      break;

    value = eval_intrinsic(form, nil, nil);
  }

  dyn_env = saved_dyn_env;

  if (!loading)
    uw_release_deferred_warnings();

  prinl(value, out_stream);
  return t;
}

static val get_home_path(void)
{
#ifdef __CYGWIN__
  struct utsname un;

  if (uname(&un) >= 0) {
    if (strncmp(un.sysname, "CYGNAL", 6) == 0)
      return getenv_wrap(lit("USERPROFILE"));
  }
#endif
  return getenv_wrap(lit("HOME"));
}

static val repl_warning(val out_stream, val exc, varg rest)
{
  val args = args_get_list(rest);

  (void) exc;

  if (cdr(args))
    uw_defer_warning(args);
  else
    format(out_stream, lit("** ~!~a\n"), car(args), nao);

  return uw_rthrow(continue_s, nil);
}

static int is_balanced_line(const wchar_t *line, void *ctx)
{
  enum state {
    ST_START, ST_CMNT, ST_PAR, ST_BKT, ST_BRC, ST_HASH,
    ST_LIT, ST_QLIT, ST_RGX, ST_RGXC, ST_RGXE, ST_CHR, ST_ESC, ST_AT,
    ST_HASH_B, ST_BUF
  };
  int count[32], sp = 0;
  enum state state[32];
  wchar_t ch;

  (void) ctx;

  count[sp] = 0;
  state[sp] = ST_START;

  while ((ch = *line++) != 0) {
  again:
    if (sp >= 30)
      return 1;

    count[sp+1] = 0;
    count[sp+2] = 0;

    switch (state[sp]) {
    case ST_START:
    case ST_PAR:
    case ST_BKT:
    case ST_BRC:
      switch (ch) {
      case ';':
        state[++sp] = ST_CMNT;
        break;
      case '#':
        state[++sp] = ST_HASH;
        break;
      case '"':
        state[++sp] = ST_LIT;
        break;
      case '`':
        state[++sp] = ST_QLIT;
        break;
      case '(':
        if (state[sp] == ST_PAR)
          count[sp]++;
        else
          state[++sp] = ST_PAR;
        break;
      case '[':
        if (state[sp] == ST_BKT)
          count[sp]++;
        else
          state[++sp] = ST_BKT;
        break;
      case '{':
        if (state[sp] == ST_BRC)
          count[sp]++;
        else
          state[++sp] = ST_BRC;
        break;
      case ')': case ']': case '}':
        {
          enum state match = ST_START;
          switch (ch) {
          case ')': match = ST_PAR; break;
          case ']': match = ST_BKT; break;
          case '}': match = ST_BRC; break;
          }

          while (sp > 0 && state[sp] != match)
            sp--;
          if (state[sp] != match)
            return 0;
          if (count[sp] == 0)
            sp--;
          else
            count[sp]--;
          break;
        }
      }
      break;
    case ST_CMNT:
      if (ch == '\r')
        sp--;
      break;
    case ST_HASH:
      switch (ch) {
      case '\\':
        state[sp] = ST_CHR;
        break;
      case '/':
        state[sp] = ST_RGX;
        break;
      case 'b':
        state[sp] = ST_HASH_B;
        break;
      case ';':
        --sp;
        break;
      default:
        --sp;
        goto again;
      }
      break;
    case ST_LIT:
      switch (ch) {
      case '"':
        sp--;
        break;
      case '\\':
        state[++sp] = ST_ESC;
        break;
      }
      break;
    case ST_QLIT:
      switch (ch) {
      case '`':
        sp--;
        break;
      case '\\':
        state[++sp] = ST_ESC;
        break;
      case '@':
        state[++sp] = ST_AT;
        break;
      }
      break;
    case ST_RGX:
      switch (ch) {
      case '/':
        sp--;
        break;
      case '[':
        state[++sp] = ST_RGXC;
        break;
      case '(':
        state[++sp] = ST_RGXE;
        break;
      case '\\':
        state[++sp] = ST_ESC;
        break;
      }
      break;
    case ST_RGXC:
      switch (ch) {
      case ']':
        sp--;
        break;
      case '\\':
        state[++sp] = ST_ESC;
        break;
      }
      break;
    case ST_RGXE:
      switch (ch) {
      case ')':
        sp--;
        break;
      case '[':
        state[++sp] = ST_RGXC;
        break;
      case '(':
        state[++sp] = ST_RGXE;
        break;
      case '\\':
        state[++sp] = ST_ESC;
        break;
      }
      break;
    case ST_CHR:
      --sp;
      break;
    case ST_ESC:
      --sp;
      break;
    case ST_AT:
      switch (ch) {
      case '(':
        state[sp] = ST_PAR;
        break;
      case '[':
        state[sp] = ST_BKT;
        break;
      case '{':
        state[sp] = ST_BRC;
        break;
      default:
        sp--;
        break;
      }
      break;
    case ST_HASH_B:
      switch (ch) {
      case '\'':
        state[sp] = ST_BUF;
        break;
      default:
        sp--;
        break;
      }
      break;
    case ST_BUF:
      switch (ch) {
      case '\'':
        sp--;
        break;
      }
      break;
    }
  }

  if (state[sp] == ST_CMNT)
    sp--;

  return sp == 0 && state[sp] == ST_START && count[sp] == 0;
}

static_forward(lino_os_t linenoise_txr_binding);

static void hist_save(lino_t *ls, val in_stream, val out_stream,
                      val histfile, const wchar_t *histfile_w,
                      val hist_len_var)
{
  val self = lit("listener");
  if (histfile_w && lino_have_new_lines(ls)) {
    val histfile_tmp = scat2(histfile, lit(".tmp"));
    const wchar_t *histfile_tmp_w = c_str(histfile_tmp, self);
    lino_t *ltmp = lino_make(coerce(mem_t *, in_stream),
                             coerce(mem_t *, out_stream));
    lino_hist_set_max_len(ltmp, c_num(cdr(hist_len_var), self));
    lino_hist_load(ltmp, histfile_w);
    lino_hist_save(ltmp, histfile_tmp_w, 0);
    if (lino_hist_save(ls, histfile_tmp_w, 1) == 0)
      rename_path(histfile_tmp, histfile);
    else
      put_line(lit("** unable to save history file"), out_stream);
    gc_hint(histfile_tmp);
    lino_free(ltmp);
  }
}

val repl(val bindings, val in_stream, val out_stream, val env)
{
  val self = lit("listener");
  lino_t *ls = if3(repl_level++,
                   lino_ctx,
                   lino_ctx = lino_make(coerce(mem_t *, in_stream),
                                        coerce(mem_t *, out_stream)));
  wchar_t *volatile line_w = 0;
  val quit_k = intern(lit("quit"), keyword_package);
  val read_k = intern(lit("read"), keyword_package);
  val prompt_k = intern(lit("prompt"), keyword_package);
  val prompt_on_k = intern(lit("prompt-on"), keyword_package);
  val p_k = intern(lit("p"), keyword_package);
  val save_k = intern(lit("save"), keyword_package);
  val counter_sym = intern(lit("*n"), user_package);
  val var_counter_sym = intern(lit("*v"), user_package);
  val result_hash_sym = intern(lit("*r"), user_package);
  val pexist_s =  intern(lit("path-exists-p"), user_package);
#ifdef __CYGWIN__
  val ppriv_s = intern(lit("tf"), user_package);
  val psafe_s = ppriv_s;
#else
  val ppriv_s = intern(lit("path-strictly-private-to-me-p"), user_package);
  val psafe_s = intern(lit("path-components-safe"), user_package);
#endif
  val ifx_s = intern(lit("ifx"), user_package);
  val result_hash = make_hash(hash_weak_none, nil);
  val done = nil;
  val counter = one;
  val home = if3(repl_level == 1, get_home_path(), nil);
  val hist1 = if2(home, scat2(home, lit("/.txr-history")));
  val hist2 = if2(home, scat2(home, lit("/.txr_history")));
  val histfile;
  const wchar_t *hist1_w = if3(home, c_str(hist1, self), 0);
  const wchar_t *hist2_w = if3(home, c_str(hist2, self), 0);
  const wchar_t *histfile_w = 0;
  val old_sig_handler = set_sig_handler(num(SIGINT), func_n2(repl_intr));
  val hist_len_var = lookup_global_var(listener_hist_len_s);
#if CONFIG_FULL_REPL
  val multi_line_var = lookup_global_var(listener_multi_line_p_s);
  val sel_inclusive_var = lookup_global_var(listener_sel_inclusive_p_s);
#endif
  val pprint_var = lookup_global_var(listener_pprint_s);
  val greedy_eval = lookup_global_var(listener_greedy_eval_s);
  val auto_parens = lookup_global_var(listener_auto_compound_s);
  val auto_infix = lookup_global_var(listener_auto_infix_s);
  val ignore_eof = lookup_global_var(listener_ignore_eof_s);
  val rw_f = func_f1v(out_stream, repl_warning);
  val saved_dyn_env = set_dyn_env(make_env(nil, nil, dyn_env));
  val brackets = mkstring(num_fast(repl_level), chr('>'));
  volatile val ignore_eof_count = nil;
  cnum i;

  env_vbind(dyn_env, stderr_s, out_stream);

  for (; bindings; bindings = cdr(bindings)) {
    val binding = car(bindings);
    reg_varl(car(binding), cdr(binding));
  }

  for (i = 1; i <= 20; i++) {
    val name = format(nil, lit("*-~d"), num_fast(i), nao);
    val sym = intern(name, user_package);
    reg_symacro(sym, list(dwim_s, result_hash_sym,
                          list(macro_time_s,
                               list(mod_s,
                                    list(minus_s, var_counter_sym,
                                         num_fast(i), nao),
                                    num_fast(100), nao), nao), nao));
  }

  reg_varl(result_hash_sym, result_hash);

#if CONFIG_FULL_REPL
  lino_set_completion_cb(ls, provide_completions, 0);
  lino_set_atom_cb(ls, provide_atom, 0);
#endif

  lino_set_enter_cb(ls, is_balanced_line, 0);
  lino_set_tempfile_suffix(ls, ".tl");

  if (home && !opt_noprofile)
    load_rcfile(home, pexist_s, psafe_s, ppriv_s);

  ignore_eof_count = cdr(ignore_eof);

  lino_hist_set_max_len(ls, c_num(cdr(hist_len_var), self));

  if (hist1_w && funcall1(pexist_s, hist1)) {
    histfile = hist1;
    histfile_w = hist1_w;
  } else if (hist2_w && funcall1(pexist_s, hist2)) {
    histfile = hist2;
    histfile_w = hist2_w;
  }

  if (histfile_w) {
    if (!funcall1(psafe_s, home)) {
      report_path_perm_problem(home);
    } else if (!funcall1(ppriv_s, histfile)) {
      report_file_perm_problem(histfile);
    }

    lino_hist_load(ls, histfile_w);
  }

  if (home && !histfile_w) {
    histfile = hist1;
    histfile_w = hist1_w;
  }

#if CONFIG_FULL_REPL
  lino_set_noninteractive(ls, opt_noninteractive);
#endif

  while (!done) {
    val prompt = format(nil, lit("~d~a "), counter, brackets,nao);
    val prev_counter = counter;
    val var_counter = mod(counter, num_fast(100));
    val var_name = format(nil, lit("*~d"), var_counter, nao);
    val var_sym = intern(var_name, user_package);
    uw_frame_t uw_handler;

    lino_hist_set_max_len(ls, c_num(cdr(hist_len_var), self));
#if CONFIG_FULL_REPL
    lino_set_multiline(ls, cdr(multi_line_var) != nil);
    lino_set_selinclusive(ls, cdr(sel_inclusive_var) != nil);
#endif
    reg_varl(counter_sym, counter);
    reg_varl(var_counter_sym, var_counter);

    uw_catch_begin (catch_all, exsym, exvals);

    uw_push_handler(&uw_handler, cons(warning_s, nil), rw_f);

    clear_error(in_stream);

    line_w = linenoise(ls, c_str(prompt, self));

    uw_pop_frame(&uw_handler);

#if CONFIG_FULL_REPL
    rplacd(multi_line_var, tnil(lino_get_multiline(ls)));
#endif

    if (line_w == 0) {
      switch (lino_get_error(ls)) {
      case lino_intr:
        put_line(lit("** intr"), out_stream);
        break;
      case lino_eof:
        if (ignore_eof_count) {
          if (integerp(ignore_eof_count)) {
            ignore_eof_count = pred(ignore_eof_count);
            if (plusp(ignore_eof_count)) {
              format(out_stream, lit("** EOF will be ignored ~s more time~a\n"),
                     ignore_eof_count,
                     if3(ignore_eof_count != one, lit("s"), lit("")), nao);
            } else if (ignore_eof_count == zero) {
              put_line(lit("** Next EOF will terminate"),
                       out_stream);
              ignore_eof_count = nil;
            } else {
              done = t;
            }
          } else {
            put_line(lit("** EOF ignored by user preference"), out_stream);
          }
        } else {
          done = t;
        }
        break;
      default:
        put_line(lit("** error reading interactive input"), out_stream);
        done = t;
        break;
      }
      goto contin;
    }

    {
      size_t wsp = wcsspn(line_w, L" \t\n\r");

      if (line_w[wsp] == 0)
        goto contin;

      if (line_w[wsp] == ';') {
        lino_hist_add(ls, line_w);
        goto contin;
      }
    }

    counter = succ(counter);

    uw_push_handler(&uw_handler, cons(warning_s, nil), rw_f);

    {
      val name = format(nil, lit("expr-~d"), prev_counter, nao);
      val line = string(line_w);
      val forms = read_objects_from_string(line, std_error, colon_k, name);
      val form = if2(and2(consp(forms), null(cdr(forms))), car(forms));
      if (form == quit_k) {
        done = t;
      } else if (form == prompt_k) {
        pprinl(prompt, out_stream);
        counter = prev_counter;
      } else if (form == prompt_on_k) {
        lino_enable_noninteractive_prompt(ls, 1);
        counter = prev_counter;
      } else if (form == p_k) {
        pprinl(prev_counter, out_stream);
        counter = prev_counter;
      } else if (form == save_k) {
        hist_save(ls, in_stream, out_stream, histfile, histfile_w, hist_len_var);
        counter = prev_counter;
      } else {
        val expr0 = if2(form != read_k,
                        if3(consp(forms),
                            if3(cdr(auto_parens) && cdr(forms),
                                forms,
                                cons(progn_s, forms)),
                            forms));
        val expr1 = if2(form != read_k,
                        if3(cdr(auto_infix), cons(ifx_s, cons(expr0, nil)),
                            expr0));
        val value = if3(form != read_k,
                        eval_intrinsic(expr1, nil, env),
                        read_eval_ret_last(nil, prev_counter,
                                           in_stream, out_stream));
        val pprin = cdr(pprint_var);
        val (*pfun)(val, val) = if3(pprin, pprinl, prinl);
#if CONFIG_FULL_REPL
        val (*tsfun)(val) = if3(pprin, tostringp, tostring);
#endif
        reg_varl(var_sym, value);
        sethash(result_hash, var_counter, value);
        pfun(value, out_stream);
#if CONFIG_FULL_REPL
        lino_set_result(ls, chk_strdup(c_str(tsfun(value), self)));
#endif
        lino_hist_add(ls, line_w);
        if (cdr(greedy_eval)) {
          val error_p = nil;
          while (bindable(value) || consp(value))
          {
            value = eval_intrinsic_noerr(value, nil, &error_p);
            /* env deliberately not passed to eval here */
            if (error_p)
              break;
            pfun(value, out_stream);
          }
        }
      }
    }

    ignore_eof_count = cdr(ignore_eof);

    uw_pop_frame(&uw_handler);

    uw_catch (exsym, exvals) {
      val exinfo = cons(exsym, exvals);
      reg_varl(var_sym, exinfo);
      sethash(result_hash, var_counter, exinfo);
      if (line_w)
        lino_hist_add(ls, line_w);

      if (uw_exception_subtype_p(exsym, syntax_error_s)) {
        format(out_stream, lit("** syntax error: ~a\n"), car(exvals), nao);
      } else if (uw_exception_subtype_p(exsym, intr_s)) {
        format(out_stream, lit("** intr\n"), nao);
      } else if (uw_exception_subtype_p(exsym, error_s)) {
        error_trace(exsym, exvals, out_stream, lit("**"));
      } else {
        format(out_stream, lit("** ~!~s exception, args: ~!~s\n"),
               exsym, exvals, nao);
      }
    }

  contin:
    uw_unwind {
      free(line_w);
      line_w = 0;
    }

    uw_catch_end;

    gc_hint(prompt);
  }

  set_sig_handler(num(SIGINT), old_sig_handler);

  dyn_env = saved_dyn_env;

  hist_save(ls, in_stream, out_stream, histfile, histfile_w, hist_len_var);

  free(line_w);
  if (--repl_level == 0) {
    lino_free(lino_ctx);
    lino_ctx = 0;
  }
  gc_hint(histfile);
  return nil;
}

val parser_errors(val parser)
{
  val self = lit("parser-errors");
  parser_t *p = coerce(parser_t *, cobj_handle(self, parser, parser_cls));
  return num(p->errors);
}

val parse_errors(val stream)
{
  val self = lit("parse-errors");
  val errors = nil;
  val parser = gethash(stream_parser_hash, stream);
  if (parser) {
    parser_t *p = coerce(parser_t *, cobj_handle(self, parser, parser_cls));
    if (p->errors)
      errors = num(p->errors);
  }
  return errors;
}

static val circref(val n)
{
  uw_throwf(error_s, lit("unresolved #~s# reference in object syntax"),
            n, nao);
}

static int lino_fileno(mem_t *stream_in)
{
  val self = lit("listener");
  val stream = coerce(val, stream_in);
  return c_num(stream_fd(stream), self);
}

static int lino_puts(mem_t *stream_in, const wchar_t *str_in)
{
  val stream = coerce(val, stream_in);
  wchar_t ch;
  while ((ch = *str_in++))
    if (ch != LINO_PAD_CHAR)
      if (put_char(chr(ch), stream) != t)
        return 0;
  flush_stream(stream);
  return 1;
}

static int lino_puts_file(mem_t *stream_in, const wchar_t *str_in)
{
  val stream = coerce(val, stream_in);
  wchar_t ch;
  while ((ch = *str_in++))
    if (put_char(chr(ch), stream) != t)
      return 0;
  return 1;
}

static wint_t lino_getch(mem_t *stream_in)
{
  val self = lit("listener");
  wint_t ret = WEOF;

  val stream, ch;

  uw_catch_begin (catch_all, sy, va);

  stream = coerce(val, stream_in);
  ch = get_char(stream);

  ret = if3(ch, convert(wint_t, c_num(ch, self)), WEOF);

  uw_catch (sy, va) {
    (void) sy;
    (void) va;
  }

  uw_unwind { }

  uw_catch_end;

  return ret;
}

static wchar_t *lino_getl(mem_t *stream_in, wchar_t *buf, size_t nchar)
{
  val self = lit("listener");
  wchar_t *ptr = buf;
  val stream = coerce(val, stream_in);

  if (nchar == 0)
    return buf;

  while (nchar-- > 1) {
    val ch = get_char(stream);
    if (!ch)
      break;
    if ((*ptr++ = c_num(ch, self)) == '\n')
      break;
  }

  *ptr++ = 0;
  return (ptr == buf + 1) ? 0 : buf;
}

static wchar_t *lino_gets(mem_t *stream_in, wchar_t *buf, size_t nchar)
{
  val self = lit("listener");
  wchar_t *ptr = buf;
  val stream = coerce(val, stream_in);

  if (nchar == 0)
    return buf;

  while (nchar-- > 1) {
    val ch = get_char(stream);
    if (!ch)
      break;
    *ptr++ = c_num(ch, self);
  }

  *ptr++ = 0;
  return (ptr == buf + 1) ? 0 : buf;
}


static int lino_feof(mem_t *stream_in)
{
  val stream = coerce(val, stream_in);
  return get_error(stream) == t;
}

static const wchli_t *lino_mode_str[] = {
  wli("r"), wli("w"), wli("a")
};

static mem_t *lino_open(const wchar_t *name_in, lino_file_mode_t mode_in)
{
  val self = lit("listener");
  val name = string(name_in);
  val mode = static_str(lino_mode_str[mode_in]);
  val ret = 0;
  ignerr_begin;
  ret = open_file(name, mode);
#if HAVE_CHMOD
  if (mode_in == lino_overwrite || mode_in == lino_append)
    (void) fchmod(c_num(stream_fd(ret), self), S_IRUSR | S_IWUSR);
#endif
  ignerr_end;
  return coerce(mem_t *, ret);
}

static mem_t *lino_open8(const char *name_in, lino_file_mode_t mode_in)
{
  val name = string_utf8(name_in);
  val mode = static_str(lino_mode_str[mode_in]);
  mem_t *ret = 0;
  ignerr_begin;
  ret = coerce(mem_t *, open_file(name, mode));
  ignerr_end;
  return ret;
}

static mem_t *lino_fdopen(int fd, lino_file_mode_t mode_in)
{
  val mode = static_str(lino_mode_str[mode_in]);
  return coerce(mem_t *, open_fileno(num(fd), mode, nil));
}

static void lino_close(mem_t *stream)
{
  (void) close_stream(coerce(val, stream), nil);
}

static_def(lino_os_t linenoise_txr_binding =
           lino_os_init(chk_malloc, chk_realloc, chk_wmalloc,
                        chk_wrealloc, chk_strdup, free,
                        lino_fileno, lino_puts, lino_puts_file, lino_getch,
                        lino_getl, lino_gets, lino_feof,
                        lino_open, lino_open8, lino_fdopen, lino_close,
                        wide_display_char_p));

static val me_json(val form, val menv)
{
  (void) menv;
  return cdr(form);
}

static struct strm_ops *shadow_detach(val stream)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
  struct shadow_context *sc = coerce(struct shadow_context *, s->shadow_obj);

  if (sc) {
    s->shadow_obj = 0;
    stream->co.ops = coerce(struct cobj_ops *, ops = sc->orig_ops);
    scanner_free_buffered_bytes(sc);
    free(sc);
  }

  return ops;
}

static void shadow_destroy_op(val stream)
{
  struct strm_ops *ops = shadow_detach(stream);
  ops->cobj_ops.destroy(stream);
}

static void shadow_mark_op(val stream)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  struct shadow_context *sc = coerce(struct shadow_context *, s->shadow_obj);
  sc->orig_ops->cobj_ops.mark(stream);
}

static val shadow_put_string(val stream, val str)
{
  struct strm_ops *ops = shadow_detach(stream);
  return ops->put_string(stream, str);
}

static val shadow_put_char(val stream, val ch)
{
  struct strm_ops *ops = shadow_detach(stream);
  return ops->put_char(stream, ch);
}

static val shadow_put_byte(val stream, int byte)
{
  struct strm_ops *ops = shadow_detach(stream);
  return ops->put_byte(stream, byte);
}

static int shadow_get_char_callback(mem_t *ctx)
{
  struct strm_base *s = coerce(struct strm_base *, ctx);
  struct shadow_context *sc = coerce(struct shadow_context *, s->shadow_obj);
  if (sc->index < sc->size) {
      return sc->buf[sc->index++];
  } else {
    val byte = sc->orig_ops->get_byte(sc->stream);
    return byte ? c_n(byte) : EOF;
  }
}

static val shadow_get_char(val stream)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  wint_t wch = utf8_decode(&s->ud, shadow_get_char_callback,
                            coerce(mem_t *, s));
  struct shadow_context *sc = coerce(struct shadow_context *, s->shadow_obj);
  struct strm_ops *ops = sc->index < sc->size
                         ? coerce(struct strm_ops *, stream->co.ops)
                         : shadow_detach(stream);
  int ch;

  if (ops->unget_byte)
    while ((ch = utf8_getc(&s->ud)) != EOF)
      ops->unget_byte(stream, ch);

  return (wch != WEOF) ? chr(wch) : nil;
}

static val shadow_unget_char(val stream, val ch)

{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  struct shadow_context *sc = coerce(struct shadow_context *, s->shadow_obj);
  struct utf8_tiny_buf bu;
  unsigned char *bend = bu.buf + sizeof bu.buf;

  bu.ptr = bend;

  (void) utf8_encode(c_chr(ch), utf8_tiny_buf_putc, coerce(mem_t *, &bu));

  if (convert(size_t, bend - bu.ptr) > sc->index)
    uw_throwf(file_error_s,
              lit("unget-char: cannot push past beginning of byte stream"),
              nao);

  while (bu.ptr < bend)
    sc->buf[--sc->index] = *bu.ptr++;

  return ch;
}

static val shadow_get_byte(val stream)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  struct shadow_context *sc = coerce(struct shadow_context *, s->shadow_obj);

  if (sc->index < sc->size) {
    return num(sc->buf[sc->index++]);
  } else {
    struct strm_ops *ops = shadow_detach(sc->stream);
    return ops->get_byte(stream);
  }
}

static val shadow_unget_byte(val stream, int byte)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  struct shadow_context *sc = coerce(struct shadow_context *, s->shadow_obj);

  if (sc->index == 0)
    uw_throwf(file_error_s,
              lit("unget-byte: cannot push past beginning of byte stream"),
              nao);

  sc->buf[--sc->index] = byte;
  return num_fast(byte);
}

static ucnum shadow_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  struct strm_ops *ops = shadow_detach(stream);
  return ops->put_buf(stream, ptr, len, pos);
}

static ucnum shadow_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  val self = lit("fill-buf");
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  struct shadow_context *sc = coerce(struct shadow_context *, s->shadow_obj);

  if (convert(size_t, len) != len || len > INT_PTR_MAX)
    uw_throwf(error_s, lit("~a: buffer too large"), self, nao);
  if (pos >= len) {
    return len;
  } else {
    size_t room = len - pos;
    size_t avail = sc->size - sc->index;
    size_t copy = min(room, avail);
    memcpy(ptr + pos, sc->buf + sc->index, copy);
    sc->index += copy;
    if (copy == avail)
      shadow_detach(stream);
    return pos + copy;
  }
}

static val shadow_close(val stream, val throw_on_error)
{
  struct strm_ops *ops = shadow_detach(stream);
  return ops->close(stream, throw_on_error);
}

static val shadow_flush(val stream)
{
  struct strm_ops *ops = shadow_detach(stream);
  return ops->flush(stream);
}

static val shadow_seek(val stream, val off, enum strm_whence whence)
{
  struct strm_ops *ops = shadow_detach(stream);
  return ops->seek(stream, off, whence);
}

static val shadow_truncate(val stream, val len)
{
  struct strm_ops *ops = shadow_detach(stream);
  return ops->truncate(stream, len);
}

static struct strm_ops shadow_ops_template =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              shadow_destroy_op,
                              shadow_mark_op,
                              cobj_eq_hash_op,
                              0),
                wli("shadow-stream"),
                shadow_put_string, shadow_put_char, shadow_put_byte,
                generic_get_string, shadow_get_char, shadow_get_byte,
                shadow_unget_char, shadow_unget_byte,
                shadow_put_buf, shadow_fill_buf,
                shadow_close, shadow_flush, shadow_seek, shadow_truncate,
                0, 0,
                0, 0, 0, 0);

static void customize_shad_ops(struct strm_ops *shad_ops,
                               struct strm_ops *ops)
{
  void (**spfn)(void) = coerce(void (**)(void), &ops->put_string);
  void (**send)(void) = coerce(void (**)(void), &ops->set_sock_peer);
  void (**dpfn)(void) = coerce(void (**)(void), &shad_ops->put_string);

  while (spfn <= send) {
    if (*spfn == 0)
      *dpfn = 0;
    else if (*dpfn == 0)
      *dpfn = *spfn;
    spfn++;
    dpfn++;
  }
}

/*
 * The purpose of this oddly named shadow stream is to claw back
 * data which has been read from the stream and placed into a buffer
 * inside our flex-generated scanner. The shadow stream patches
 * into the target stream, replacing its operations with its own.
 * When the shadow stream is done doling out the recovered bytes,
 * it uninstalls itself via shadow_detach. Output and positioning
 * operations also trigger a detach.
 */
void parser_shadow_stream_attach(val self, val target_stream)
{
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, target_stream, stream_cls));
  struct strm_ops *ops = coerce(struct strm_ops *, target_stream->co.ops);

  if (!s->shadow_obj) {
    val parser = gethash(stream_parser_hash, target_stream);
    parser_t *p = parser ? coerce(parser_t *, cobj_handle(self, parser, parser_cls)) : 0;
    scanner_t *yyscan = p ? p->scanner : 0;
    struct strm_ops *shad_ops = 0;
    struct shadow_context *sc = 0;
    int i;

    if (!p || !yyscan || !scanner_has_buffered_bytes(yyscan))
      return;

    for (i = 0; i < SHADOW_TAB_SIZE; i++) {
      if (shadow_tab[i].from == 0)
        break;
      if (shadow_tab[i].from == ops) {
        shad_ops = shadow_tab[i].to;
        break;
      }
    }

    if (i >= SHADOW_TAB_SIZE)
      internal_error("shadow_tab overflow");

    if (shad_ops == 0) {
      shad_ops = coerce(struct strm_ops *,
                        chk_copy_obj(coerce(mem_t *, &shadow_ops_template),
                                     sizeof shadow_ops_template));
      customize_shad_ops(shad_ops, ops);
    }

    sc = coerce(struct shadow_context *, chk_malloc(sizeof *sc));
    sc->orig_ops = ops;
    sc->stream = target_stream;
    scanner_get_buffered_bytes(sc, yyscan);

    s->shadow_obj = coerce(mem_t *, sc);
    target_stream->co.ops = coerce(struct cobj_ops *, shad_ops);
  }
}

void parse_init(void)
{
  parser_s = intern(lit("parser"), user_package);
  circref_s = intern(lit("circref"), system_package);
  intr_s = intern(lit("intr"), user_package);
  listener_hist_len_s = intern(lit("*listener-hist-len*"), user_package);
  listener_multi_line_p_s = intern(lit("*listener-multi-line-p*"), user_package);
  listener_sel_inclusive_p_s = intern(lit("*listener-sel-inclusive-p*"), user_package);
  listener_pprint_s = intern(lit("*listener-pprint-p*"), user_package);
  listener_greedy_eval_s = intern(lit("*listener-greedy-eval-p*"), user_package);
  listener_auto_compound_s = intern(lit("*listener-auto-compound-p*"), user_package);
  listener_auto_infix_s = intern(lit("*listener-auto-infix-p*"), user_package);
  listener_ignore_eof_s = intern(lit("*listener-ignore-eof*"), user_package);
  rec_source_loc_s = intern(lit("*rec-source-loc*"), user_package);
  read_unknown_structs_s = intern(lit("*read-unknown-structs*"), user_package);
  read_bad_json_s = intern(lit("*read-bad-json*"), user_package);
  read_json_int_s = intern(lit("*read-json-int*"), user_package);
  json_s = intern(lit("json"), user_package);
  unique_s = gensym(nil);

  parser_cls = cobj_register(parser_s);

  protect(&stream_parser_hash, &unique_s,
          &catch_all, &catch_error, convert(val *, 0));
  stream_parser_hash = make_hash(hash_weak_and, nil);
  catch_all = cons(t, nil);
  catch_error = cons(error_s, nil);

  parser_l_init();

  lino_init(&linenoise_txr_binding);

  reg_var(listener_hist_len_s, num_fast(500));
  reg_var(listener_multi_line_p_s, t);
  reg_var(listener_sel_inclusive_p_s, t);
  reg_var(listener_pprint_s, nil);
  reg_var(listener_greedy_eval_s, nil);
  reg_var(listener_auto_compound_s, nil);
  reg_var(listener_auto_infix_s, nil);
  reg_var(listener_ignore_eof_s, nil);
  reg_var(rec_source_loc_s, nil);
  reg_var(read_unknown_structs_s, nil);
  reg_var(read_bad_json_s, nil);
  reg_var(read_json_int_s, nil);
  reg_fun(circref_s, func_n1(circref));
  reg_fun(intern(lit("parse-errors"), user_package), func_n1(parse_errors));
  reg_fun(intern(lit("repl"), system_package), func_n4(repl));
  reg_mac(json_s, func_n2(me_json));
}

void parser_free_all(void)
{
  int i;
  for (i = 0; i < SHADOW_TAB_SIZE; i++) {
    free(shadow_tab[i].to);
    shadow_tab[i].to = 0;
  }
}