/* k.sf */ /* Generated by #F $Id$ */ #ifdef PROFILE #define host host_module_k #endif #define MODULE module_k #define LOAD() /* standard includes */ #include #include #include #include /* extra includes */ #include #include #include #include #include /* standard definitions */ #ifdef NAN_BOXING #include 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; }