skint/k.c

/* k.sf */
/* Generated by #F $Id$ */
#ifdef PROFILE
#define host host_module_k
#endif
#define MODULE module_k
#define LOAD()

/* standard includes */
#include <stdio.h>
#include <stddef.h>
#include <stdlib.h>
#include <assert.h>
/* extra includes */
#include <math.h>
#include <errno.h>
#include <ctype.h>
#include <string.h>
#include <time.h>

/* standard definitions */
#ifdef NAN_BOXING
#include <stdint.h>
typedef int64_t obj;          /* pointers are this size, higher 16 bits and lower bit zero */
typedef int64_t cxoint_t;     /* same thing, used as integer */
typedef struct {              /* type descriptor */
  const char *tname;          /* name (debug) */
  void (*free)(void*);        /* deallocator */
} cxtype_t;

#define notobjptr(o)          (((cxoint_t)(o) - (cxoint_t)cxg_heap) & cxg_hmask)
#define isobjptr(o)           (!notobjptr(o))
#define notaptr(o)            ((o) & 0xffff000000000001ULL)
#define isaptr(o)             (!notaptr(o))
#else
typedef ptrdiff_t obj;        /* pointers are this size, lower bit zero */
typedef ptrdiff_t cxoint_t;   /* same thing, used as integer */
typedef struct {              /* type descriptor */
  const char *tname;          /* name (debug) */
  void (*free)(void*);        /* deallocator */
} cxtype_t;

#define notobjptr(o)          (((char*)(o) - (char*)cxg_heap) & cxg_hmask)
#define isobjptr(o)           (!notobjptr(o))
#define notaptr(o)            ((o) & 1)
#define isaptr(o)             (!notaptr(o))
#endif

#define obj_from_obj(o)       (o)
#define obj_from_objptr(p)    ((obj)(p))
#define obj_from_size(n)      (((cxoint_t)(n) << 1) | 1)

#define objptr_from_objptr(p) (p)
#define objptr_from_obj(o)    ((obj*)(o))

#define size_from_obj(o)      ((int)((o) >> 1))

#define obj_from_case(n)      obj_from_objptr(cases+(n))
#define case_from_obj(o)      (objptr_from_obj(o)-cases)
#define obj_from_ktrap()      obj_from_size(0x5D56F806)
#define obj_from_void(v)      ((void)(v), obj_from_size(0x6F56DF77))

#define bool_from_obj(o)      (o)
#define bool_from_bool(b)     (b)
#define bool_from_size(s)     (s)

#define void_from_void(v)     (void)(v)
#define void_from_obj(o)      (void)(o)

#define rreserve(m)           if (r + (m) >= cxg_rend) r = cxm_rgc(r, m)
#define hpushptr(p, pt, l)    (hreserve(2, l), *--hp = (obj)(p), *--hp = (obj)(pt), (obj)(hp+1))   
#define hbsz(s)               ((s) + 1) /* 1 extra word to store block size */
#define hreserve(n, l)        ((hp < cxg_heap + (n)) ? hp = cxm_hgc(r, r+(l), hp, n) : hp)
#define hendblk(n)            (*--hp = obj_from_size(n), (obj)(hp+1))
#define hblklen(p)            size_from_obj(((obj*)(p))[-1])
#define hblkref(p, i)         (((obj*)(p))[i])

typedef obj (*cxhost_t)(obj);
typedef struct cxroot_tag {
  int globc; obj **globv;
  struct cxroot_tag *next;
} cxroot_t;

extern obj *cxg_heap;
extern obj *cxg_hp;
extern cxoint_t cxg_hmask;
extern cxroot_t *cxg_rootp;
extern obj *cxm_rgc(obj *regs, size_t needs);
extern obj *cxm_hgc(obj *regs, obj *regp, obj *hp, size_t needs);
extern obj *cxg_regs, *cxg_rend;
extern void cxm_check(int x, char *msg);
extern void *cxm_cknull(void *p, char *msg);
extern int cxg_rc;
extern char **cxg_argv;

/* extra definitions */
/* basic object representation */
#ifdef NAN_BOXING
#define isim0(o)    (((o) & 0xffffffff00000003ULL) == 3) /* 30 bits of payload */
#define isimm(o, t) (((o) & 0xffffffff000000ffULL) == (((t) << 2) | 1)) /* 24 */
#ifdef NDEBUG
  #define getim0s(o) (long)(((((int32_t)(o) >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000)
  #define getimmu(o, t) (long)(((o) >> 8) & 0xffffff)
#else
  extern long getim0s(obj o);
  extern long getimmu(obj o, int t);
#endif
#define mkim0(v) ((obj)((((v) & 0x000000003fffffffULL) << 2) | 3))
#define mkimm(v, t) ((obj)((((v) & 0x0000000000ffffffULL) << 8) | ((t) << 2) | 1))
#else
#define isim0(o)    (((o) & 3) == 3)
#define isimm(o, t) (((o) & 0xff) == (((t) << 2) | 1))
#ifdef NDEBUG
  #define getim0s(o) (long)(((((int)(o) >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000)
  #define getimmu(o, t) (long)(((o) >> 8) & 0xffffff)
#else
  extern long getim0s(obj o);
  extern long getimmu(obj o, int t);
#endif
#define mkim0(o) (obj)((((o) & 0x3fffffff) << 2) | 3)
#define mkimm(o, t) (obj)((((o) & 0xffffff) << 8) | ((t) << 2) | 1)
#define FLONUMS_BOXED
#endif
#ifdef NDEBUG
   static int isnative(obj o, cxtype_t *tp) 
     { return isobjptr(o) && objptr_from_obj(o)[-1] == (obj)tp;  }
   #define getnative(o, t) ((void*)(*objptr_from_obj(o)))
#else
  extern int isnative(obj o, cxtype_t *tp);
  extern void *getnative(obj o, cxtype_t *tp);
#endif
extern int istagged(obj o, int t);
#ifdef NDEBUG
  #define cktagged(o, t) (o)
  #define taggedlen(o, t) (hblklen(o)-1) 
  #define taggedref(o, t, i) (&hblkref(o, (i)+1))
#else
  extern obj cktagged(obj o, int t);
  extern int taggedlen(obj o, int t);
  extern obj* taggedref(obj o, int t, int i); 
#endif
extern int istyped(obj o);
#ifdef NDEBUG
  #define cktyped(o, t) (o)
  #define typedtype(o) (&hblkref(o, 0))
  #define typedlen(o) (hblklen(o)-1) 
  #define typedref(o, i) (&hblkref(o, (i)+1))
#else
  extern obj cktyped(obj o);
  extern obj* typedtype(obj o); 
  extern int typedlen(obj o);
  extern obj* typedref(obj o, int i); 
#endif
/* booleans */
#define TRUE_ITAG 0
typedef int bool_t;
#define is_bool_obj(o) (!((o) & ~(obj)1))
#define is_bool_bool(b) ((void)(b), 1)
#define void_from_bool(b) (void)(b)
#define obj_from_bool(b) ((b) ? mkimm(0, TRUE_ITAG) : 0)
/* void */
#define VOID_ITAG 1
#define mkvoid() mkimm(0, VOID_ITAG)
#define isvoid(o) ((o) == mkimm(0, VOID_ITAG))
#undef obj_from_void
#define obj_from_void(v) ((void)(v), mkimm(0, VOID_ITAG))
/* unit */
#define obj_from_unit() (obj_from_size(0x6DF6F577))
/* numbers */
#define FIXNUM_BIT 30
#define FIXNUM_MIN -536870912
#define FIXNUM_MAX 536870911
#ifdef NDEBUG
#define fxneg(x) (-(x))
#define fxabs(x) (labs(x))
#define fxadd(x, y) ((x) + (y))
#define fxsub(x, y) ((x) - (y))
#define fxmul(x, y) ((x) * (y))
/* exact integer division */
#define fxdiv(x, y) ((x) / (y))  
/* truncated division (common/C99) */
#define fxquo(x, y) ((x) / (y))  
#define fxrem(x, y) ((x) % (y))
/* floor division */
static long fxmqu(long x, long y) {
  long q = x / y; return ((x < 0 && y > 0) || (x > 0 && y < 0)) ? q - 1 : q;
}
static long fxmlo(long x, long y) {
  long r = x % y; return ((r < 0 && y > 0) || (r > 0 && y < 0)) ? r + y : r;
}
/* euclidean division */
static long fxeuq(long x, long y) { 
  long q = x / y, r = x % y; return (r < 0) ? ((y > 0) ? q - 1 : q + 1) : q;
}
static long fxeur(long x, long y) {
  long r = x % y; return (r < 0) ? ((y > 0) ? r + y : r - y) : r;
} 
static long fxgcd(long x, long y) {
  long a = labs(x), b = labs(y), c; while (b) c = a%b, a = b, b = c; 
  return a;
} 
#define fxasl(x, y) ((x) << (y))
#define fxasr(x, y) ((x) >> (y))
#define fxflo(f) ((long)(f))
#else
extern long fxneg(long x);
extern long fxabs(long x);
extern long fxadd(long x, long y);
extern long fxsub(long x, long y);
extern long fxmul(long x, long y);
extern long fxdiv(long x, long y);
extern long fxquo(long x, long y);
extern long fxrem(long x, long y);
extern long fxmqu(long x, long y);
extern long fxmlo(long x, long y);
extern long fxeuq(long x, long y);
extern long fxeur(long x, long y);
extern long fxgcd(long x, long y);
extern long fxasl(long x, long y);
extern long fxasr(long x, long y);
extern long fxflo(double f);
#endif
static int flisint(double f) { return f > -HUGE_VAL && f < HUGE_VAL && f == floor(f); }
extern long fxpow(long x, long y);
extern long fxsqrt(long x);
extern int fxifdv(long x, long y, long *pi, double *pd);
extern double flquo(double x, double y);
extern double flrem(double x, double y);
extern double flmqu(double x, double y);
extern double flmlo(double x, double y);
extern double flgcd(double x, double y);
extern double flround(double x);
extern int strtofxfl(char *s, int radix, long *pl, double *pd);
/* fixnums */
typedef long fixnum_t;
#define is_fixnum_obj(o) (isim0(o))
#define is_fixnum_fixnum(i) ((void)(i), 1)
#define is_bool_fixnum(i) ((void)(i), 0)
#define is_fixnum_bool(i) ((void)(i), 0)
#define fixnum_from_obj(o) (getim0s(o))
#define fixnum_from_fixnum(i) (i)
#define fixnum_from_flonum(l,x) ((fixnum_t)(x))
#define bool_from_fixnum(i) ((void)(i), 1)
#define void_from_fixnum(i) (void)(i)
#define obj_from_fixnum(i) mkim0((fixnum_t)(i))
/* flonums */
#ifndef FLONUMS_BOXED
typedef double flonum_t;
#define is_flonum_obj(o) (((o) & 0xffff000000000000ULL) != 0ULL)
#define is_flonum_flonum(f) ((void)(f), 1)
#define is_flonum_bool(f) ((void)(f), 0)
#define is_bool_flonum(f) ((void)(f), 0)
#define is_fixnum_flonum(i) ((void)(i), 0)
#define is_flonum_fixnum(i) ((void)(i), 0)
#define flonum_from_flonum(l, f) (f)
#define flonum_from_fixnum(x) ((flonum_t)(x))
#define bool_from_flonum(f) ((void)(f), 0)
#define void_from_flonum(l, f) (void)(f)
union iod { cxoint_t i; double d; };
static double flonum_from_obj(obj o) { 
  union iod u; 
  assert(is_flonum_obj(o));
  u.i = ~o; 
  return u.d; 
}
static obj obj_from_flonum(int rc, double d) { 
  union iod u; 
  u.d = d; 
  assert(is_flonum_obj(~u.i));
  return ~u.i; 
}
#else /* FLONUMS_BOXED */
extern cxtype_t *FLONUM_NTAG;
typedef double flonum_t;
#define is_flonum_obj(o) (isnative(o, FLONUM_NTAG))
#define is_flonum_flonum(f) ((void)(f), 1)
#define is_flonum_bool(f) ((void)(f), 0)
#define is_bool_flonum(f) ((void)(f), 0)
#define is_fixnum_flonum(i) ((void)(i), 0)
#define is_flonum_fixnum(i) ((void)(i), 0)
#define flonum_from_obj(o) (*(flonum_t*)getnative(o, FLONUM_NTAG))
#define flonum_from_flonum(l, f) (f)
#define flonum_from_fixnum(x) ((flonum_t)(x))
#define bool_from_flonum(f) ((void)(f), 0)
#define void_from_flonum(l, f) (void)(f)
#define obj_from_flonum(l, f) hpushptr(dupflonum(f), FLONUM_NTAG, l)
extern flonum_t *dupflonum(flonum_t f);
#endif
/* characters */
#define CHAR_ITAG 2
typedef int char_t;
#define ischar(o) (isimm(o, CHAR_ITAG))
#define is_char_obj(o) (isimm(o, CHAR_ITAG))
#define is_char_char(i) ((void)(i), 1)
#define is_char_bool(i) ((void)(i), 0)
#define is_bool_char(i) ((void)(i), 0)
#define is_char_fixnum(i) ((void)(i), 0)
#define is_fixnum_char(i) ((void)(i), 0)
#define is_char_flonum(i) ((void)(i), 0)
#define is_flonum_char(i) ((void)(i), 0)
#define char_from_obj(o) ((int)getimmu(o, CHAR_ITAG))
#define char_from_char(i) (i)
#define bool_from_char(i) ((void)(i), 1)
#define void_from_char(i) (void)(i)
#define obj_from_char(i) mkimm(i, CHAR_ITAG)
/* strings */
extern cxtype_t *STRING_NTAG;
#define isstring(o) (isnative(o, STRING_NTAG))
#define stringdata(o) ((int*)getnative(o, STRING_NTAG))
#define sdatachars(d) ((char*)((d)+1))
#define stringlen(o) (*stringdata(o))
#define stringchars(o) ((char*)(stringdata(o)+1))
#define hpushstr(l, s) hpushptr(s, STRING_NTAG, l)
#ifdef NDEBUG
  #define stringref(o, i) (stringchars(o)+(i))
#else
  extern char* stringref(obj o, int i);
#endif
extern int *newstring(char *s);
extern int *newstringn(char *s, int n);
extern int *allocstring(int n, int c);
extern int *substring(int *d, int from, int to);
extern int *stringcat(int *d0, int *d1);
extern int *dupstring(int *d);
extern void stringfill(int *d, int c);
extern int strcmp_ci(char *s1, char *s2);
/* vectors */
#define VECTOR_BTAG 1
#define isvector(o) istagged(o, VECTOR_BTAG)
#define vectorref(v, i) *taggedref(v, VECTOR_BTAG, i)
#define vectorlen(v) taggedlen(v, VECTOR_BTAG)
/* bytevectors */
extern cxtype_t *BYTEVECTOR_NTAG;
#define isbytevector(o) (isnative(o, BYTEVECTOR_NTAG))
#define bytevectordata(o) ((int*)getnative(o, BYTEVECTOR_NTAG))
#define bvdatabytes(d) ((unsigned char*)((d)+1))
#define bytevectorlen(o) (*bytevectordata(o))
#define bytevectorbytes(o) (bvdatabytes(bytevectordata(o)))
#define hpushu8v(l, s) hpushptr(s, BYTEVECTOR_NTAG, l)
static int is_byte_obj(obj o) { return (obj_from_fixnum(0) <= o && o <= obj_from_fixnum(255)); } 
#define byte_from_obj(o) byte_from_fixnum(fixnum_from_obj(o))
#ifdef NDEBUG
  #define byte_from_fixnum(n) ((unsigned char)(n))
#else
  static unsigned char byte_from_fixnum(int n) { assert(0 <= n && n <= 255); return n; } 
#endif
#define byte_from_obj(o) byte_from_fixnum(fixnum_from_obj(o))
#ifdef NDEBUG
  #define bytevectorref(o, i) (bytevectorbytes(o)+(i))
#else
  extern unsigned char* bytevectorref(obj o, int i);
#endif
extern int *newbytevector(unsigned char *s, int n);
extern int *makebytevector(int n, int c);
extern int *allocbytevector(int n);
extern int *dupbytevector(int *d);
extern int bytevectoreq(int *d0, int *d1);
extern int *subbytevector(int *d, int from, int to);
/* boxes */
#define BOX_BTAG 2
#define isbox(o) istagged(o, BOX_BTAG)
#define boxref(o) *taggedref(o, BOX_BTAG, 0)
/* null */
#define NULL_ITAG 3
#define mknull() mkimm(0, NULL_ITAG)
#define isnull(o) ((o) == mkimm(0, NULL_ITAG))
/* pairs and lists */
#define PAIR_BTAG 3
#define ispair(o) istagged(o, PAIR_BTAG)
#define car(o) *taggedref(o, PAIR_BTAG, 0)
#define cdr(o) *taggedref(o, PAIR_BTAG, 1)
extern int islist(obj l);
/* symbols */
#define SYMBOL_ITAG 4
#define issymbol(o) (isimm(o, SYMBOL_ITAG))
#define mksymbol(i) mkimm(i, SYMBOL_ITAG)
#define getsymbol(o) getimmu(o, SYMBOL_ITAG)
extern char *symbolname(int sym);
extern int internsym(char *name);
/* records */
#define isrecord(o) istyped(o)
#define recordrtd(r) *typedtype(r)
#define recordlen(r) typedlen(r)
#define recordref(r, i) *typedref(r, i)
/* procedures */
extern int isprocedure(obj o);
extern int procedurelen(obj o);
extern obj* procedureref(obj o, int i);
/* apply and dotted lambda list */
extern obj appcases[];
/* eof */
#define EOF_ITAG 7
#define mkeof() mkimm(0, EOF_ITAG)
#define iseof(o) ((o) == mkimm(0, EOF_ITAG))
/* shebangs (#! directives or script start lines) */
#define SHEBANG_ITAG 8
#define isshebang(o) (isimm(o, SHEBANG_ITAG))
#define mkshebang(i) mkimm(i, SHEBANG_ITAG)
#define getshebang(o) getimmu(o, SHEBANG_ITAG)
/* input ports */
typedef struct { /* extends cxtype_t */
  const char *tname;
  void (*free)(void*);
  int (*close)(void*);
  int (*getch)(void*);
  int (*ungetch)(int, void*);
} cxtype_iport_t;
extern cxtype_t *IPORT_CLOSED_NTAG;
extern cxtype_t *IPORT_FILE_NTAG;
extern cxtype_t *IPORT_STRING_NTAG;
extern cxtype_t *IPORT_BYTEVECTOR_NTAG;
static cxtype_iport_t *iportvt(obj o) { 
  cxtype_t *pt; if (!isobjptr(o)) return NULL;
  pt = (cxtype_t*)objptr_from_obj(o)[-1];
  if (pt != IPORT_CLOSED_NTAG && pt != IPORT_FILE_NTAG &&
      pt != IPORT_STRING_NTAG && pt != IPORT_BYTEVECTOR_NTAG) return NULL; 
  else return (cxtype_iport_t*)pt; }
#define ckiportvt(o) ((cxtype_iport_t*)cxm_cknull(iportvt(o), "iportvt"))
#define isiport(o) (iportvt(o) != NULL)
#define iportdata(o) ((void*)(*objptr_from_obj(o)))
static int iportgetc(obj o) {
  cxtype_iport_t *vt = iportvt(o); void *pp = iportdata(o);
  assert(vt); return vt->getch(pp);
}
static int iportpeekc(obj o) {
  cxtype_iport_t *vt = iportvt(o); void *pp = iportdata(o); int c;
  assert(vt); c = vt->getch(pp); if (c != EOF) vt->ungetch(c, pp); return c;
}
/* closed input ports */
#define mkiport_file(l, fp) hpushptr(fp, IPORT_FILE_NTAG, l)
/* string input ports */
typedef struct { char *p; void *base; } sifile_t;
extern sifile_t *sialloc(char *p, void *base);
#define mkiport_string(l, fp) hpushptr(fp, IPORT_STRING_NTAG, l)
/* bytevector input ports */
typedef struct { unsigned char *p, *e; void *base; } bvifile_t;
extern bvifile_t *bvialloc(unsigned char *p, unsigned char *e, void *base);
#define mkiport_bytevector(l, fp) hpushptr(fp, IPORT_BYTEVECTOR_NTAG, l)
/* output ports */
typedef struct { /* extends cxtype_t */
  const char *tname;
  void (*free)(void*);
  int (*close)(void*);
  int (*putch)(int, void*);
  int (*flush)(void*);
} cxtype_oport_t;
extern cxtype_t *OPORT_CLOSED_NTAG;
extern cxtype_t *OPORT_FILE_NTAG;
extern cxtype_t *OPORT_STRING_NTAG;
extern cxtype_t *OPORT_BYTEVECTOR_NTAG;
static cxtype_oport_t *oportvt(obj o) { 
  cxtype_t *pt; if (!isobjptr(o)) return NULL;
  pt = (cxtype_t*)objptr_from_obj(o)[-1];
  if (pt != OPORT_CLOSED_NTAG && pt != OPORT_FILE_NTAG && 
      pt != OPORT_STRING_NTAG && pt != OPORT_BYTEVECTOR_NTAG) return NULL; 
  else return (cxtype_oport_t*)pt; }
#define ckoportvt(o) ((cxtype_oport_t*)cxm_cknull(oportvt(o), "oportvt"))
#define isoport(o) (oportvt(o) != NULL)
#define oportdata(o) ((void*)(*objptr_from_obj(o)))
static void oportputc(int c, obj o) {
  cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
  assert(vt); vt->putch(c, pp);
}
static void oportputs(char *s, obj o) {
  cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
  assert(vt); while (*s) vt->putch(*s++, pp);
}
static void oportwrite(char *s, int n, obj o) {
  cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
  assert(vt); while (n-- > 0) vt->putch(*s++, pp);
}
static void oportflush(obj o) {
  cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
  assert(vt); vt->flush(pp);
}
/* closed output ports */
#define mkoport_file(l, fp) hpushptr(fp, OPORT_FILE_NTAG, l)
/* string output ports */
typedef struct cbuf_tag { char *buf; char *fill; char *end; } cbuf_t;
extern cbuf_t* newcb(void);
extern void freecb(cbuf_t* pcb);
extern int cbputc(int c, cbuf_t* pcb);
extern size_t cblen(cbuf_t* pcb);
extern char* cbdata(cbuf_t* pcb);
#define mkoport_string(l, fp) hpushptr(fp, OPORT_STRING_NTAG, l)
/* bytevector output ports */
#define mkoport_bytevector(l, fp) hpushptr(fp, OPORT_BYTEVECTOR_NTAG, l)
extern int iscircular(obj x);
extern int iseqv(obj x, obj y);
extern obj ismemv(obj x, obj l);
extern obj isassv(obj x, obj l);
extern int isequal(obj x, obj y);
extern obj ismember(obj x, obj l);
extern obj isassoc(obj x, obj l);
/* S-expression writers */
extern void oportputsimple(obj x, obj p, int disp);
extern void oportputcircular(obj x, obj p, int disp);
extern void oportputshared(obj x, obj p, int disp);
#include "i.h"

/* cx globals */
obj cx__2Acurrent_2Derror_2A; /* *current-error* */
obj cx__2Acurrent_2Dinput_2A; /* *current-input* */
obj cx__2Acurrent_2Doutput_2A; /* *current-output* */
obj cx__2Adynamic_2Dstate_2A; /* *dynamic-state* */
obj cx__2Aglobals_2A; /* *globals* */
obj cx__2Atransformers_2A; /* *transformers* */
obj cx_callmv_2Dadapter_2Dclosure; /* callmv-adapter-closure */
obj cx_continuation_2Dadapter_2Dcode; /* continuation-adapter-code */
obj cx_decode; /* decode */
obj cx_decode_2Dsexp; /* decode-sexp */
obj cx_execute_2Dthunk_2Dclosure; /* execute-thunk-closure */
obj cx_initialize_2Dmodules; /* initialize-modules */
obj cx_install_2Dglobal_2Dlambdas; /* install-global-lambdas */
obj cx_main; /* main */
obj cx_make_2Dclosure; /* make-closure */
obj cx_tcode_2Drepl; /* tcode-repl */
static obj cx__2316; /* constant #16 */
static obj cx__2320; /* constant #20 */

/* gc roots */
static obj *globv[] = {
  &cx__2Acurrent_2Derror_2A,
  &cx__2Acurrent_2Dinput_2A,
  &cx__2Acurrent_2Doutput_2A,
  &cx__2Adynamic_2Dstate_2A,
  &cx__2Aglobals_2A,
  &cx__2Atransformers_2A,
  &cx_callmv_2Dadapter_2Dclosure,
  &cx_continuation_2Dadapter_2Dcode,
  &cx_decode,
  &cx_decode_2Dsexp,
  &cx_execute_2Dthunk_2Dclosure,
  &cx_initialize_2Dmodules,
  &cx_install_2Dglobal_2Dlambdas,
  &cx_make_2Dclosure,
  &cx__2316,
  &cx__2320,
};

static cxroot_t root = {
  sizeof(globv)/sizeof(obj *), globv, NULL
};

/* entry points */
static obj host(obj);
static obj cases[10] = {
  (obj)host,  (obj)host,  (obj)host,  (obj)host,  (obj)host,
  (obj)host,  (obj)host,  (obj)host,  (obj)host,  (obj)host,
};

/* host procedure */
#define MAX_HOSTREGS 16
static obj host(obj pc)
{
  register obj *r = cxg_regs;
  register obj *hp = cxg_hp;
  register int rc = cxg_rc;
  rreserve(MAX_HOSTREGS); 
jump: 
  switch (case_from_obj(pc)) {

case 0: /* load module */
    cx__2316 = (hpushstr(0, newstring("K5")));
    { static char s[] = { 36, 123, 64, 40, 121, 52, 58, 114, 101, 112, 108, 41, 91, 48, 48, 125, 0 };
    cx__2320 = (hpushstr(0, newstring(s))); }
    { /* make-vector */
    obj o; int i = 0, c = (+991);
    hreserve(hbsz(c+1), 0); /* 0 live regs */
    o = (mknull()); /* gc-safe */
    while (i++ < c) *--hp = o;
    *--hp = obj_from_size(VECTOR_BTAG);
    cx__2Aglobals_2A = (hendblk(c+1)); }
    { /* cons */ 
    hreserve(hbsz(3), 0); /* 0 live regs */
    *--hp = (mknull());
    *--hp = obj_from_bool(0);
    *--hp = obj_from_size(PAIR_BTAG); 
    cx__2Adynamic_2Dstate_2A = (hendblk(3)); }
    cx__2Acurrent_2Dinput_2A = obj_from_bool(0);
    cx__2Acurrent_2Doutput_2A = obj_from_bool(0);
    cx__2Acurrent_2Derror_2A = obj_from_bool(0);
    { /* define execute-thunk-closure */
    static obj c[] = { obj_from_objptr(vmcases+0) }; 
    cx_execute_2Dthunk_2Dclosure = obj_from_objptr(c); }
    { /* define make-closure */
    static obj c[] = { obj_from_objptr(vmcases+1) };
    cx_make_2Dclosure = obj_from_objptr(c); }
    { /* define decode-sexp */
    static obj c[] = { obj_from_objptr(vmcases+2) };
    cx_decode_2Dsexp = obj_from_objptr(c); }
    { /* define decode */
    static obj c[] = { obj_from_objptr(vmcases+3) };
    cx_decode = obj_from_objptr(c); }
    cx__2Atransformers_2A = (mknull());
    cx_continuation_2Dadapter_2Dcode = obj_from_bool(0);
    { /* define decode */
    static obj c[] = { obj_from_objptr(vmcases+3) };
    r[0] = obj_from_objptr(c); }
    hreserve(hbsz(0+1), 1); /* 1 live regs */
    *--hp = obj_from_case(1);
    r[1] = (hendblk(0+1));
    r[2+0] = r[0];  
    pc = objptr_from_obj(r[2+0])[0];
    r[2+1] = r[1];  
    r[2+2] = (cx__2316);
    r += 2; /* shift reg wnd */
    rreserve(MAX_HOSTREGS);
    rc = 3;
    goto jump;

case 1: /* clo ek r */
    assert(rc == 3);
    r += 1; /* shift reg. wnd */
    /* ek r */
    { /* define make-closure */
    static obj c[] = { obj_from_objptr(vmcases+1) };
    r[2] = obj_from_objptr(c); }
    hreserve(hbsz(0+1), 3); /* 3 live regs */
    *--hp = obj_from_case(2);
    r[3] = (hendblk(0+1));
    r[4+0] = r[2];  
    pc = objptr_from_obj(r[4+0])[0];
    r[4+1] = r[3];  
    r[4+2] = r[1];  
    r += 4; /* shift reg wnd */
    rreserve(MAX_HOSTREGS);
    rc = 3;
    goto jump;

case 2: /* clo ek r */
    assert(rc == 3);
    r += 1; /* shift reg. wnd */
    /* ek r */
    cx_callmv_2Dadapter_2Dclosure = r[1];  
    { /* define install-global-lambdas */
    static obj c[] = { obj_from_objptr(vmcases+6) };
    cx_install_2Dglobal_2Dlambdas = obj_from_objptr(c); }
    { /* define install-global-lambdas */
    static obj c[] = { obj_from_objptr(vmcases+6) };
    r[2] = obj_from_objptr(c); }
    hreserve(hbsz(0+1), 3); /* 3 live regs */
    *--hp = obj_from_case(3);
    r[3] = (hendblk(0+1));
    r[0] = r[2];  
    pc = objptr_from_obj(r[0])[0];
    r[1] = r[3];  
    rreserve(MAX_HOSTREGS);
    rc = 2;
    goto jump;

case 3: /* clo ek . */
    assert(rc >= 2);
    r[2] = obj_from_void(0); /* ignored */
    r += 1; /* shift reg. wnd */
    /* ek . */
    { /* define initialize-modules */
    static obj c[] = { obj_from_objptr(vmcases+7) };
    cx_initialize_2Dmodules = obj_from_objptr(c); }
    { /* define initialize-modules */
    static obj c[] = { obj_from_objptr(vmcases+7) };
    r[2] = obj_from_objptr(c); }
    hreserve(hbsz(0+1), 3); /* 3 live regs */
    *--hp = obj_from_case(4);
    r[3] = (hendblk(0+1));
    r[0] = r[2];  
    pc = objptr_from_obj(r[0])[0];
    r[1] = r[3];  
    rreserve(MAX_HOSTREGS);
    rc = 2;
    goto jump;

case 4: /* clo ek . */
    assert(rc >= 2);
    r[2] = obj_from_void(0); /* ignored */
    r += 1; /* shift reg. wnd */
    /* ek . */
    { static obj c[] = { obj_from_case(5) }; cx_tcode_2Drepl = (obj)c; }
    { static obj c[] = { obj_from_case(8) }; cx_main = (obj)c; }
    r[2] = obj_from_void(0);
    r[3+0] = r[0];
    pc = 0; /* exit from module init */
    r[3+1] = r[2];  
    r += 3; /* shift reg wnd */
    rc = 2;
    goto jump;

case 5: /* tcode-repl k */
    assert(rc == 2);
    r += 1; /* shift reg. wnd */
gs_tcode_2Drepl: /* k */
    { /* define decode */
    static obj c[] = { obj_from_objptr(vmcases+3) };
    r[1] = obj_from_objptr(c); }
    hreserve(hbsz(1+1), 2); /* 2 live regs */
    *--hp = r[0];  
    *--hp = obj_from_case(6);
    r[2] = (hendblk(1+1));
    r[3+0] = r[1];  
    pc = objptr_from_obj(r[3+0])[0];
    r[3+1] = r[2];  
    r[3+2] = (cx__2320);
    r += 3; /* shift reg wnd */
    rreserve(MAX_HOSTREGS);
    rc = 3;
    goto jump;

case 6: /* clo ek r */
    assert(rc == 3);
    { obj* p = objptr_from_obj(r[0]);
    r[1+2] = p[1]; }
    r += 1; /* shift reg. wnd */
    /* ek r k */
    { /* define make-closure */
    static obj c[] = { obj_from_objptr(vmcases+1) };
    r[3] = obj_from_objptr(c); }
    hreserve(hbsz(1+1), 4); /* 4 live regs */
    *--hp = r[2];  
    *--hp = obj_from_case(7);
    r[4] = (hendblk(1+1));
    r[5+0] = r[3];  
    pc = objptr_from_obj(r[5+0])[0];
    r[5+1] = r[4];  
    r[5+2] = r[1];  
    r += 5; /* shift reg wnd */
    rreserve(MAX_HOSTREGS);
    rc = 3;
    goto jump;

case 7: /* clo ek r */
    assert(rc == 3);
    { obj* p = objptr_from_obj(r[0]);
    r[1+2] = p[1]; }
    r += 1; /* shift reg. wnd */
    /* ek r k */
    { /* define execute-thunk-closure */
    static obj c[] = { obj_from_objptr(vmcases+0) }; 
    r[3] = obj_from_objptr(c); }
    r[4+0] = r[3];  
    pc = objptr_from_obj(r[4+0])[0];
    r[4+1] = r[2];  
    r[4+2] = r[1];  
    r += 4; /* shift reg wnd */
    rreserve(MAX_HOSTREGS);
    rc = 3;
    goto jump;

case 8: /* main k argv */
    assert(rc == 3);
    r += 1; /* shift reg. wnd */
gs_main: /* k argv */
    hreserve(hbsz(1+1), 2); /* 2 live regs */
    *--hp = r[0];  
    *--hp = obj_from_case(9);
    r[2] = (hendblk(1+1));
    r[0] = r[2];  
    goto gs_tcode_2Drepl;

case 9: /* clo ek r */
    assert(rc == 3);
    { obj* p = objptr_from_obj(r[0]);
    r[1+2] = p[1]; }
    r += 1; /* shift reg. wnd */
    /* ek r k */
  if (((r[1]) == obj_from_bool(1))) {
    r[0] = r[2];  
    pc = objptr_from_obj(r[0])[0];
    r[1] = obj_from_ktrap();
    r[2] = ((0) ? obj_from_bool(0) : obj_from_void(0));
    rreserve(MAX_HOSTREGS);
    rc = 3;
    goto jump;
  } else {
    r[0] = r[2];  
    r[1] = obj_from_bool(0);
    goto gs_main;
  }

default: /* inter-host call */
    cxg_hp = hp;
    cxm_rgc(r, MAX_HOSTREGS);
    cxg_rc = rc;
    return pc;
  }
}

/* module load */
void MODULE(void)
{
  obj pc;
  if (!root.next) {
    root.next = cxg_rootp;
    cxg_rootp = &root;
    LOAD();
    pc = obj_from_case(0);
    cxg_rc = 0;
    while (pc) pc = (*(cxhost_t*)pc)(pc); 
    assert(cxg_rc == 2);
  }
}

/* basic runtime */
#define HEAP_SIZE 131072 /* 2^17 */
#define REGS_SIZE 4092

obj *cxg_heap = NULL;
cxoint_t cxg_hmask = 0;
obj *cxg_hp = NULL;
static cxroot_t cxg_root = { 0, NULL, NULL };
cxroot_t *cxg_rootp = &cxg_root;
obj *cxg_regs = NULL, *cxg_rend = NULL;
int cxg_rc = 0;
char **cxg_argv = NULL;

static obj *cxg_heap2 = NULL;
size_t cxg_hsize = 0; 
static cxoint_t cxg_hmask2 = 0;
int cxg_gccount = 0, cxg_bumpcount = 0;

static obj *toheap2(obj* p, obj *hp, obj *h1, cxoint_t m1, obj *h2, cxoint_t m2)
{
  obj o = *p, *op, fo, *fop;
  if (((char*)(o) - (char*)h1) & m1) return hp;
  fo = (op = objptr_from_obj(o))[-1]; assert(fo);
  if (notaptr(fo)) {
    fop = op + size_from_obj(fo); while (fop >= op) *--hp = *--fop;
    *p = *fop = obj_from_objptr(hp+1);
  } else if (((char*)(fo) - (char*)h2) & m2) {
    *--hp = *op--; *--hp = *op;
    *p = *op = obj_from_objptr(hp+1);
  } else *p = fo;
  return hp;
}

static void finalize(obj *hp1, obj *he1, obj *h2, cxoint_t m2)
{
  while (hp1 < he1) {
    obj fo = *hp1++; assert(fo);
    if (notaptr(fo)) hp1 += size_from_obj(fo);
    else if (((char*)(fo) - (char*)h2) & m2) ((cxtype_t*)fo)->free((void*)*hp1++);
    else if (notaptr(fo = objptr_from_obj(fo)[-1])) hp1 += size_from_obj(fo);
    else ++hp1;
  } assert(hp1 == he1);
}

static obj *relocate(cxroot_t *pr, obj *regs, obj *regp, 
obj *he2, obj *he1, obj *hp, obj *h1, cxoint_t m1, obj *h2, cxoint_t m2) 
{
  obj *p, *hp1 = hp; hp = he2;
  for (p = regs; p < regp; ++p) hp = toheap2(p, hp, h1, m1, h2, m2);
  for (; pr; pr = pr->next) {
    obj **pp = pr->globv; int c = pr->globc;
    while (c-- > 0) hp = toheap2(*pp++, hp, h1, m1, h2, m2);
  }
  for (p = he2; p > hp; --p) hp = toheap2(p-1, hp, h1, m1, h2, m2);
  if (he1) finalize(hp1, he1, h2, m2);
  return hp;
}

obj *cxm_hgc(obj *regs, obj *regp, obj *hp, size_t needs) 
{
  obj *h1 = cxg_heap, *h2 = cxg_heap2; cxoint_t m1 = cxg_hmask, m2 = cxg_hmask2;
  size_t hs = cxg_hsize; cxroot_t *pr = cxg_rootp;

  obj *h = h1, *he1 = h1 + hs, *he2 = h2 + hs; 
  ++cxg_gccount;
  if (h1) hp = relocate(pr, regs, regp, he2, he1, hp, h1, m1, h2, m2), 
    needs += (h2 + hs - hp)*2; /* make heap half empty */
  else hp = h2 + hs;
  if (hs < needs) {
    size_t s = HEAP_SIZE; while (s < needs) s *= 2;
    m2 = 1 | ~(s*sizeof(obj)-1);
    if (!(h = realloc(h1, s*sizeof(obj)))) { perror("alloc[h]"); exit(2); }
    h1 = h2; h2 = h; he2 = h2 + s; he1 = 0; /* no finalize flag */
    if (h1) hp = relocate(pr, regs, regp, he2, he1, hp, h1, m1, h2, m2);
    else hp = h2 + s;
    if (!(h = realloc(h1, s*sizeof(obj)))) { perror("alloc[h]"); exit(2); }
    hs = s; m1 = m2; ++cxg_bumpcount;
  }
  h1 = h2; h2 = h;

  cxg_heap = h1; cxg_hmask = m1; cxg_heap2 = h2; cxg_hmask2 = m2;
  cxg_hsize = hs; return cxg_hp = hp;
}

obj *cxm_rgc(obj *regs, size_t needs) 
{
  obj *p = cxg_regs; assert(needs > 0);
  if (!p || cxg_rend < p + needs) {
    size_t roff = regs ? regs - p : 0;
    if (!(p = realloc(p, needs*sizeof(obj)))) { perror("alloc[r]"); exit(2); }
    cxg_regs = p; cxg_rend = p + needs;
    regs = p + roff;
  }
  if (regs && regs > p) while (needs--) *p++ = *regs++;
  return cxg_regs;
}

void cxm_check(int x, char *msg)
{
  if (!x) { 
    perror(msg); exit(2); 
  }
}

void *cxm_cknull(void *p, char *msg)
{
  cxm_check(p != NULL, msg); 
  return p;
}

/* os entry point */
int main(int argc, char **argv) {
  int res; obj pc;
  obj retcl[1] = { 0 };
  cxm_rgc(NULL, REGS_SIZE);
  cxg_argv = argv;
  MODULE();
  cxg_regs[0] = cx_main;
  cxg_regs[1] = (obj)retcl;
  cxg_regs[2] = (obj)argv;
  cxg_rc = 3;
  pc = objptr_from_obj(cx_main)[0];
  while (pc) pc = (*(cxhost_t*)pc)(pc); 
  assert(cxg_rc == 3);
  res = (cxg_regs[2] != 0); 
  return res; 
}