mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-25 21:58:54 +01:00
faster read, minor fixes
This commit is contained in:
ESL
parent
74d652f3d9
commit
8d8721892e
10 changed files with 404 additions and 271 deletions
267
i.c
267
i.c
|
|
@ -26,6 +26,11 @@ static obj *rds_intgtab(obj *r, obj *sp, obj *hp);
|
||||||
static obj *rds_stox(obj *r, obj *sp, obj *hp);
|
static obj *rds_stox(obj *r, obj *sp, obj *hp);
|
||||||
static obj *rds_stoc(obj *r, obj *sp, obj *hp);
|
static obj *rds_stoc(obj *r, obj *sp, obj *hp);
|
||||||
static obj *init_modules(obj *r, obj *sp, obj *hp);
|
static obj *init_modules(obj *r, obj *sp, obj *hp);
|
||||||
|
#if 1 // READ
|
||||||
|
typedef struct { int ci; cxtype_iport_t *vt; void *pp; cbuf_t *pcb; } renv_t;
|
||||||
|
static obj *rddatum(obj *r, obj *sp, obj *hp, renv_t *e);
|
||||||
|
static const char *rdiserr(obj x);
|
||||||
|
#endif
|
||||||
|
|
||||||
/* platform-dependent optimizations */
|
/* platform-dependent optimizations */
|
||||||
#if defined(__clang__)
|
#if defined(__clang__)
|
||||||
|
|
@ -159,9 +164,6 @@ static int istagged_inline(obj o, int t) { return isobjptr(o) && hblkref(o, 0) =
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
/* vm tuple representation (c != 1) */
|
/* vm tuple representation (c != 1) */
|
||||||
#define istuple(x) istagged(x, 0)
|
|
||||||
#define tupleref(x,i) *taggedref(x, 0, i)
|
|
||||||
#define tuplelen(x) taggedlen(x, 0)
|
|
||||||
#define tuplebsz(c) hbsz((c)+1)
|
#define tuplebsz(c) hbsz((c)+1)
|
||||||
#define hend_tuple(c) (*--hp = obj_from_size(0), hendblk((c)+1))
|
#define hend_tuple(c) (*--hp = obj_from_size(0), hendblk((c)+1))
|
||||||
|
|
||||||
|
|
@ -282,7 +284,7 @@ static void _sck(obj *s) {
|
||||||
#define is_proc(o) isvmclo(o)
|
#define is_proc(o) isvmclo(o)
|
||||||
#define proc_len(o) vmclolen(o)
|
#define proc_len(o) vmclolen(o)
|
||||||
#define proc_ref(o, i) vmcloref(o, i)
|
#define proc_ref(o, i) vmcloref(o, i)
|
||||||
#define is_tuple(o) (isrecord(o) && recordrtd(o) == 0)
|
#define is_tuple(o) istuple(o)
|
||||||
#define tuple_len(o) tuplelen(o)
|
#define tuple_len(o) tuplelen(o)
|
||||||
#define tuple_ref(o, i) tupleref(o, i)
|
#define tuple_ref(o, i) tupleref(o, i)
|
||||||
#define is_record(o) (isrecord(o) && recordrtd(o) != 0)
|
#define is_record(o) (isrecord(o) && recordrtd(o) != 0)
|
||||||
|
|
@ -580,6 +582,8 @@ define_instrhelper(cxi_failactype) {
|
||||||
{ ac = _x; spush((obj)"procedure"); musttail return cxi_failactype(IARGS); } } while (0)
|
{ ac = _x; spush((obj)"procedure"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||||
#define ckz(x) do { obj _x = (x); if (unlikely(!is_box(_x))) \
|
#define ckz(x) do { obj _x = (x); if (unlikely(!is_box(_x))) \
|
||||||
{ ac = _x; spush((obj)"box, cell, or promise"); musttail return cxi_failactype(IARGS); } } while (0)
|
{ ac = _x; spush((obj)"box, cell, or promise"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||||
|
#define ckt(x) do { obj _x = (x); if (unlikely(!is_tuple(_x))) \
|
||||||
|
{ ac = _x; spush((obj)"tuple"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||||
#define ckg(x) do { obj _x = (x); if (unlikely(!isintegrable(_x))) \
|
#define ckg(x) do { obj _x = (x); if (unlikely(!isintegrable(_x))) \
|
||||||
{ ac = _x; spush((obj)"integrable entry"); musttail return cxi_failactype(IARGS); } } while (0)
|
{ ac = _x; spush((obj)"integrable entry"); musttail return cxi_failactype(IARGS); } } while (0)
|
||||||
#define cksb(x) do { obj _x = (x); if (unlikely(!is_shebang(_x))) \
|
#define cksb(x) do { obj _x = (x); if (unlikely(!is_shebang(_x))) \
|
||||||
|
|
@ -1550,6 +1554,36 @@ define_instruction(rrtd) {
|
||||||
gonexti();
|
gonexti();
|
||||||
}
|
}
|
||||||
|
|
||||||
|
define_instruction(tupp) {
|
||||||
|
obj x = ac, y = spop();
|
||||||
|
if (is_void(y)) {
|
||||||
|
ac = bool_obj(is_tuple(ac));
|
||||||
|
} else {
|
||||||
|
ckk(y);
|
||||||
|
ac = bool_obj(is_tuple(ac) && tuple_len(ac) == get_fixnum(y));
|
||||||
|
}
|
||||||
|
gonexti();
|
||||||
|
}
|
||||||
|
|
||||||
|
define_instruction(tup) {
|
||||||
|
int i, n; obj o = *ip++;
|
||||||
|
/* special arrangement for handcoded proc */
|
||||||
|
if (!o) o = ac; n = get_fixnum(o);
|
||||||
|
hp_reserve(tuplebsz(n));
|
||||||
|
for (i = n-1; i >= 0; --i) *--hp = sref(i);
|
||||||
|
ac = hend_tuple(n);
|
||||||
|
sdrop(n);
|
||||||
|
gonexti();
|
||||||
|
}
|
||||||
|
|
||||||
|
define_instruction(tget) {
|
||||||
|
obj x = spop(); int i;
|
||||||
|
ckt(ac); ckk(x);
|
||||||
|
i = get_fixnum(x);
|
||||||
|
if (i >= tuple_len(ac)) failtype(x, "valid tuple index");
|
||||||
|
ac = tuple_ref(ac, i);
|
||||||
|
gonexti();
|
||||||
|
}
|
||||||
|
|
||||||
define_instruction(vecp) {
|
define_instruction(vecp) {
|
||||||
ac = bool_obj(is_vector(ac));
|
ac = bool_obj(is_vector(ac));
|
||||||
|
|
@ -3492,6 +3526,34 @@ define_instruction(rdtk) {
|
||||||
gonexti();
|
gonexti();
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#if 1 // READ
|
||||||
|
define_instruction(rdsd) {
|
||||||
|
cxtype_iport_t *vt = iportvt(ac); renv_t e;
|
||||||
|
if (!vt || (vt->spt & SPT_BINARY)) failactype("text input port");
|
||||||
|
ckz(sref(0)); /* 2nd arg is a box for shared alist */
|
||||||
|
e.ci = 0; e.vt = vt; e.pp = iportdata(ac); e.pcb = newcb();
|
||||||
|
spush(ac); /* make sure port is not garbage-collected */
|
||||||
|
spush(rk); rk = box_ref(sref(2)); /* shared alist or #f */
|
||||||
|
unload_ip(); /* ip->rx */
|
||||||
|
hp = rddatum(r, sp, hp, &e); /* result in ra */
|
||||||
|
reload_ac(); /* ra->ac, read result */
|
||||||
|
reload_ip(); /* rx->ip */
|
||||||
|
box_ref(sref(2)) = rk; /* shared alist */
|
||||||
|
rk = spop(); /* restrore saved rk */
|
||||||
|
sdrop(2); /* drop box and port */
|
||||||
|
freecb(e.pcb);
|
||||||
|
gonexti();
|
||||||
|
}
|
||||||
|
|
||||||
|
define_instruction(rders) {
|
||||||
|
const char *es = rdiserr(ac);
|
||||||
|
if (!es) ac = bool_obj(0);
|
||||||
|
else ac = string_obj(newstring((char *)es));
|
||||||
|
gonexti();
|
||||||
|
}
|
||||||
|
|
||||||
|
#endif
|
||||||
|
|
||||||
define_instruction(eofp) {
|
define_instruction(eofp) {
|
||||||
ac = bool_obj(is_eof(ac));
|
ac = bool_obj(is_eof(ac));
|
||||||
gonexti();
|
gonexti();
|
||||||
|
|
@ -3502,7 +3564,6 @@ define_instruction(eof) {
|
||||||
gonexti();
|
gonexti();
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
define_instruction(wrc) {
|
define_instruction(wrc) {
|
||||||
obj x = ac, y = spop(); ckc(x); ckw(y);
|
obj x = ac, y = spop(); ckc(x); ckw(y);
|
||||||
oportputc(get_char(x), y);
|
oportputc(get_char(x), y);
|
||||||
|
|
@ -4346,7 +4407,7 @@ static obj *rds_elt(obj *r, obj *sp, obj *hp)
|
||||||
}
|
}
|
||||||
|
|
||||||
/* protects registers from r to sp, in: ra=port, out: ra=sexp/eof */
|
/* protects registers from r to sp, in: ra=port, out: ra=sexp/eof */
|
||||||
static obj *rds_sexp(obj *r, obj *sp, obj *hp)
|
static obj *rds_sexp(obj *r, obj *sp, obj *hp) /* returns new hp */
|
||||||
{
|
{
|
||||||
obj port = ra;
|
obj port = ra;
|
||||||
int c = iportgetc(port);
|
int c = iportgetc(port);
|
||||||
|
|
@ -4790,7 +4851,6 @@ static obj *rds_stoc(obj *r, obj *sp, obj *hp)
|
||||||
return hp;
|
return hp;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
/* protects registers from r to sp */
|
/* protects registers from r to sp */
|
||||||
static obj *rds_intgtab(obj *r, obj *sp, obj *hp)
|
static obj *rds_intgtab(obj *r, obj *sp, obj *hp)
|
||||||
{
|
{
|
||||||
|
|
@ -5113,3 +5173,196 @@ static obj *init_modules(obj *r, obj *sp, obj *hp)
|
||||||
hp = init_module(r, sp, hp, (const char **)t_code);
|
hp = init_module(r, sp, hp, (const char **)t_code);
|
||||||
return hp;
|
return hp;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#if 1 // READ
|
||||||
|
/* internal recursive read procedure */
|
||||||
|
|
||||||
|
/* local non-readable objects: tokens, errors */
|
||||||
|
#define RDTOK_RPAR mkimm(1, EOF_ITAG)
|
||||||
|
#define RDTOK_RBRK mkimm(2, EOF_ITAG)
|
||||||
|
#define RDTOK_DOT mkimm(3, EOF_ITAG)
|
||||||
|
#define RDERR_UNXEOF mkimm(4, EOF_ITAG)
|
||||||
|
#define RDERR_UNXTOK mkimm(5, EOF_ITAG)
|
||||||
|
#define RDERR_UNXDOT mkimm(6, EOF_ITAG)
|
||||||
|
#define RDERR_UNXCLO mkimm(7, EOF_ITAG)
|
||||||
|
#define RDERR_DOTLOC mkimm(8, EOF_ITAG)
|
||||||
|
#define RDERR_INVTK mkimm(9, EOF_ITAG)
|
||||||
|
#define RDERR_INVNUM mkimm(10, EOF_ITAG)
|
||||||
|
#define RDERR_INVBYTE mkimm(11, EOF_ITAG)
|
||||||
|
#define RDERR_INVREF mkimm(12, EOF_ITAG)
|
||||||
|
#define RDERR_INVDEF mkimm(13, EOF_ITAG)
|
||||||
|
#define RDERR_SIMPLE mkimm(14, EOF_ITAG)
|
||||||
|
|
||||||
|
/* protects registers from r to sp; in: rk=shared, out: ra=sexp/eof/err */
|
||||||
|
static obj *rddatum(obj *r, obj *sp, obj *hp, renv_t *e) /* returns new hp */
|
||||||
|
{
|
||||||
|
/* ra is gc-protected, can be used freely; so is sp, but should be restored */
|
||||||
|
int tk; char *s;
|
||||||
|
nexttk:
|
||||||
|
tk = slex(e->vt->getch, e->vt->ungetch, e->pp, e->pcb); s = cbdata(e->pcb);
|
||||||
|
switch (tk) {
|
||||||
|
case TT_EOF: ra = mkeof(); break;
|
||||||
|
case TT_ERR: ra = RDERR_INVTK; break;
|
||||||
|
case TT_CLOSE: ra = RDTOK_RPAR; break;
|
||||||
|
case TT_CLOSE2: ra = RDTOK_RBRK; break;
|
||||||
|
case TT_DOT: ra = RDTOK_DOT; break;
|
||||||
|
case TT_FALSE: ra = obj_from_bool(0); break;
|
||||||
|
case TT_TRUE: ra = obj_from_bool(1); break;
|
||||||
|
case TT_NUMBER: {
|
||||||
|
int radix = 10; long l; double d;
|
||||||
|
switch (strtofxfl(s, radix, &l, &d)) {
|
||||||
|
case 'e': ra = obj_from_fixnum(l); break;
|
||||||
|
case 'i': ra = obj_from_flonum(sp-r, d); break;
|
||||||
|
default : ra = RDERR_INVNUM; break;
|
||||||
|
}
|
||||||
|
} break;
|
||||||
|
case TT_SYMBOL: {
|
||||||
|
char *p; if (e->ci) for (p = s; *p; ++p) *p = tolower(*p); // todo: utf8
|
||||||
|
ra = mksymbol(internsym(s));
|
||||||
|
} break;
|
||||||
|
case TT_CHAR: ra = obj_from_char(*s); break; // todo: utf8
|
||||||
|
case TT_STRING: ra = hpushstr(sp-r, newstring(s)); break;
|
||||||
|
case TT_SHEBANG: ra = mkshebang(internsym(s)); break;
|
||||||
|
case TT_SHEBANG_FC: case TT_SHEBANG_NF: {
|
||||||
|
e->ci = (tk == TT_SHEBANG_FC); // todo: e->vt->ctl(CTLOP_SETFC, e->pp, e->ci);
|
||||||
|
goto nexttk;
|
||||||
|
} break;
|
||||||
|
case TT_HSEMI: {
|
||||||
|
hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
if (ra == mkeof()) ra = RDERR_UNXEOF;
|
||||||
|
else if (ra == RDTOK_RPAR || ra == RDTOK_RBRK || ra == RDTOK_DOT) ra = RDERR_UNXTOK;
|
||||||
|
else if (isimm(ra, EOF_ITAG)) /* error: keep it */ ;
|
||||||
|
else goto nexttk;
|
||||||
|
} break;
|
||||||
|
case TT_QUOTE: s = "quote"; goto abbrev;
|
||||||
|
case TT_QQUOTE: s = "quasiquote"; goto abbrev;
|
||||||
|
case TT_UNQUOTE: s = "unquote"; goto abbrev;
|
||||||
|
case TT_UNQSPL: s = "unquote-splicing"; abbrev: {
|
||||||
|
hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
if (ra == mkeof()) ra = RDERR_UNXEOF;
|
||||||
|
else if (ra == RDTOK_RPAR || ra == RDTOK_RBRK || ra == RDTOK_DOT) ra = RDERR_UNXTOK;
|
||||||
|
else if (isimm(ra, EOF_ITAG)) /* error in ra: keep it */ ;
|
||||||
|
else { /* normal element */
|
||||||
|
hreserve(pairbsz()*2, sp-r);
|
||||||
|
*--hp = mknull(); *--hp = ra; ra = hend_pair();
|
||||||
|
*--hp = ra; *--hp = mksymbol(internsym(s)); ra = hend_pair();
|
||||||
|
}
|
||||||
|
} break;
|
||||||
|
case TT_HREF: {
|
||||||
|
obj k = fixnum_obj(atoi(s)), p;
|
||||||
|
if (!rk) ra = RDERR_SIMPLE;
|
||||||
|
else if (p = isassv(k, rk), is_pair(p)) ra = pair_cdr(p);
|
||||||
|
else ra = RDERR_INVREF;
|
||||||
|
} break;
|
||||||
|
case TT_HDEF: {
|
||||||
|
obj k = fixnum_obj(atoi(s)), p, t;
|
||||||
|
if (!rk) ra = RDERR_SIMPLE;
|
||||||
|
else if (p = isassv(k, rk), is_pair(p)) ra = RDERR_INVDEF;
|
||||||
|
else { /* add empty loc (as tuple) to shared */
|
||||||
|
hreserve(tuplebsz(1)+pairbsz()*2, sp-r);
|
||||||
|
*--hp = bool_obj(0); t = hend_tuple(1);
|
||||||
|
*--hp = t; *--hp = k; p = hend_pair();
|
||||||
|
*--hp = rk; *--hp = p; rk = hend_pair();
|
||||||
|
/* push tuple and read next exp carefully */
|
||||||
|
spush(t); hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
if (ra == mkeof()) ra = RDERR_UNXEOF;
|
||||||
|
else if (isimm(ra, EOF_ITAG)) /* error in ra: keep it */ ;
|
||||||
|
else if (is_tuple(ra)) ra = RDERR_INVDEF;
|
||||||
|
else tuple_ref(sref(0), 0) = ra; /* store sexp in loc */
|
||||||
|
sdrop(1); /* pop tuple */
|
||||||
|
}
|
||||||
|
} break;
|
||||||
|
case TT_BOX: {
|
||||||
|
hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
if (ra == mkeof()) ra = RDERR_UNXEOF;
|
||||||
|
else if (ra == RDTOK_RPAR || ra == RDTOK_RBRK || ra == RDTOK_DOT) ra = RDERR_UNXTOK;
|
||||||
|
else if (isimm(ra, EOF_ITAG)) /* error in ra: keep it */ ;
|
||||||
|
else { /* normal element */
|
||||||
|
hreserve(boxbsz(), sp-r);
|
||||||
|
*--hp = ra; ra = hend_box();
|
||||||
|
}
|
||||||
|
} break;
|
||||||
|
case TT_OPENLIST: case TT_OPENLIST2: {
|
||||||
|
obj cob = (tk == TT_OPENLIST) ? RDTOK_RPAR : RDTOK_RBRK;
|
||||||
|
spush(bool_obj(0)); spush(bool_obj(0)); /* l: sref(1) lp: sref(0) */
|
||||||
|
morel: hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
if (ra == mkeof()) ra = RDERR_UNXEOF;
|
||||||
|
else if (ra == RDTOK_DOT) {
|
||||||
|
hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
if (ra == mkeof()) ra = RDERR_UNXEOF;
|
||||||
|
else if (ra == RDTOK_RPAR || ra == RDTOK_RBRK || ra == RDTOK_DOT) ra = RDERR_UNXTOK;
|
||||||
|
else if (isimm(ra, EOF_ITAG)) /* error: keep it */ ;
|
||||||
|
else if (sref(0) == bool_obj(0)) ra = RDERR_DOTLOC;
|
||||||
|
else { pair_cdr(sref(0)) = ra; ra = sref(1); }
|
||||||
|
if (!isimm(ra, EOF_ITAG)) { /* normal val: get close tk */
|
||||||
|
sref(1) = ra; /* save, rddatum overrides it */
|
||||||
|
hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
ra = (ra == cob) ? sref(1) : RDERR_DOTLOC;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (ra == cob) ra = (sref(0) == bool_obj(0)) ? mknull() : sref(1);
|
||||||
|
else if (ra == RDTOK_RPAR || ra == RDTOK_RBRK) ra = RDERR_UNXCLO;
|
||||||
|
else if (isimm(ra, EOF_ITAG)) /* error: keep it */ ;
|
||||||
|
else { /* normal element */
|
||||||
|
hreserve(pairbsz(), sp-r);
|
||||||
|
*--hp = mknull(); *--hp = ra;
|
||||||
|
ra = hend_pair();
|
||||||
|
if (sref(0) == bool_obj(0)) sref(0) = sref(1) = ra;
|
||||||
|
else sref(0) = pair_cdr(sref(0)) = ra;
|
||||||
|
goto morel;
|
||||||
|
}
|
||||||
|
sdrop(2);
|
||||||
|
} break;
|
||||||
|
case TT_OPENVEC: {
|
||||||
|
size_t n = 0, i;
|
||||||
|
morev: hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
if (ra == mkeof()) { ra = RDERR_UNXEOF; sdrop(n); }
|
||||||
|
else if (ra == RDTOK_RBRK || ra == RDTOK_DOT) { ra = RDERR_UNXTOK; sdrop(n); }
|
||||||
|
else if (ra == RDTOK_RPAR) {
|
||||||
|
hreserve(vecbsz(n), sp-r); for (i = n; i > 0; --i) *--hp = spop(); ra = hend_vec(n);
|
||||||
|
}
|
||||||
|
else if (isimm(ra, EOF_ITAG)) /* error: keep it */ sdrop(n);
|
||||||
|
else { /* normal element */ spush(ra); ++n; goto morev; }
|
||||||
|
} break;
|
||||||
|
case TT_OPENU8VEC: {
|
||||||
|
cbuf_t *pcb = newcb();
|
||||||
|
moreu: hp = rddatum(r, sp, hp, e); /* result in ra */
|
||||||
|
if (ra == mkeof()) ra = RDERR_UNXEOF;
|
||||||
|
else if (ra == RDTOK_RBRK || ra == RDTOK_DOT) ra = RDERR_UNXTOK;
|
||||||
|
else if (ra == RDTOK_RPAR) ra = hpushu8v(sp-r, newbytevector((unsigned char *)cbdata(pcb), (int)cblen(pcb)));
|
||||||
|
else if (isimm(ra, EOF_ITAG)) /* error: keep it */ ;
|
||||||
|
else if (!is_byte(ra)) ra = RDERR_INVBYTE;
|
||||||
|
else { /* normal byte */ cbputc(get_byte(ra), pcb); goto moreu; }
|
||||||
|
freecb(pcb);
|
||||||
|
} break;
|
||||||
|
/* TT_HDEF/TT_HREF are not yet implemented */
|
||||||
|
default: ra = RDERR_UNXTOK; break;
|
||||||
|
}
|
||||||
|
return hp;
|
||||||
|
}
|
||||||
|
|
||||||
|
static const char *rdiserr(obj x)
|
||||||
|
{
|
||||||
|
switch (x) {
|
||||||
|
case RDTOK_RPAR: return "unmatched )";
|
||||||
|
case RDTOK_RBRK: return "unmatched ]";
|
||||||
|
case RDTOK_DOT: return "dot . outside of list syntax";
|
||||||
|
case RDERR_UNXEOF: return "unexpected end-of-file";
|
||||||
|
case RDERR_UNXTOK: return "unexpected token";
|
||||||
|
case RDERR_UNXDOT: return "unexpected dot syntax";
|
||||||
|
case RDERR_UNXCLO: return "unexpected closing paren";
|
||||||
|
case RDERR_DOTLOC: return "invalid dot syntax location";
|
||||||
|
case RDERR_INVTK: return "invalid token";
|
||||||
|
case RDERR_INVNUM: return "invalid or unsupported number syntax";
|
||||||
|
case RDERR_INVBYTE: return "invalid byte constant";
|
||||||
|
case RDERR_INVREF: return "invalid #N# shared reference";
|
||||||
|
case RDERR_INVDEF: return "invalid #N= shared definition";
|
||||||
|
case RDERR_SIMPLE: return "unexpected #N=/#N# in simple read";
|
||||||
|
}
|
||||||
|
return NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
|
||||||
7
i.h
7
i.h
|
|
@ -443,6 +443,9 @@ declare_instruction(rlen, "O3", 0, "record-length",
|
||||||
declare_instruction(rget, "O4", 0, "record-ref", '2', AUTOGL)
|
declare_instruction(rget, "O4", 0, "record-ref", '2', AUTOGL)
|
||||||
declare_instruction(rput, "O5", 0, "record-set!", '3', AUTOGL)
|
declare_instruction(rput, "O5", 0, "record-set!", '3', AUTOGL)
|
||||||
declare_instruction(rrtd, "O6", 0, "record-type-descriptor", '1', AUTOGL)
|
declare_instruction(rrtd, "O6", 0, "record-type-descriptor", '1', AUTOGL)
|
||||||
|
declare_instruction(tupp, "O7\0Y9", 0, "tuple?", 'b', AUTOGL)
|
||||||
|
declare_instruction(tup, "O8", 1, "tuple", '#', "O8(f)]0")
|
||||||
|
declare_instruction(tget, "O9", 0, "tuple-ref", '2', AUTOGL)
|
||||||
declare_instruction(vtol, "X0", 0, "%vector->list1", '1', AUTOGL)
|
declare_instruction(vtol, "X0", 0, "%vector->list1", '1', AUTOGL)
|
||||||
declare_instruction(ltov, "X1", 0, "list->vector", '1', AUTOGL)
|
declare_instruction(ltov, "X1", 0, "list->vector", '1', AUTOGL)
|
||||||
declare_instruction(stol, "X2", 0, "%string->list1", '1', AUTOGL)
|
declare_instruction(stol, "X2", 0, "%string->list1", '1', AUTOGL)
|
||||||
|
|
@ -505,6 +508,10 @@ declare_instruction(rda8, "R4\0Pi", 0, "peek-u8",
|
||||||
declare_instruction(rd8r, "R5\0Pi", 0, "u8-ready?", 'u', AUTOGL)
|
declare_instruction(rd8r, "R5\0Pi", 0, "u8-ready?", 'u', AUTOGL)
|
||||||
declare_instruction(rdln, "R6\0Pi", 0, "read-line", 'u', AUTOGL)
|
declare_instruction(rdln, "R6\0Pi", 0, "read-line", 'u', AUTOGL)
|
||||||
declare_instruction(rdtk, "R7", 0, "%read-token", '2', AUTOGL)
|
declare_instruction(rdtk, "R7", 0, "%read-token", '2', AUTOGL)
|
||||||
|
#if 1 // READ
|
||||||
|
declare_instruction(rdsd, "Rd", 0, "%read-datum", '2', AUTOGL)
|
||||||
|
declare_instruction(rders, "Re", 0, "%read-datum-error-string", '1', AUTOGL)
|
||||||
|
#endif
|
||||||
declare_instruction(eofp, "R8", 0, "eof-object?", '1', AUTOGL)
|
declare_instruction(eofp, "R8", 0, "eof-object?", '1', AUTOGL)
|
||||||
declare_instruction(eof, "R9", 0, "eof-object", '0', AUTOGL)
|
declare_instruction(eof, "R9", 0, "eof-object", '0', AUTOGL)
|
||||||
declare_instruction(wrc, "W0\0Po", 0, "write-char", 'b', AUTOGL)
|
declare_instruction(wrc, "W0\0Po", 0, "write-char", 'b', AUTOGL)
|
||||||
|
|
|
||||||
|
|
@ -1 +1,4 @@
|
||||||
(import (only (skint) implementation-version))
|
(import (only (skint) implementation-version))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -3076,4 +3076,12 @@
|
||||||
(test (write-data write-simple '(#() #(a) #(19 21 c)))
|
(test (write-data write-simple '(#() #(a) #(19 21 c)))
|
||||||
'("#()" "#(a)" "#(19 21 c)"))
|
'("#()" "#(a)" "#(19 21 c)"))
|
||||||
|
|
||||||
|
;; Skint extras
|
||||||
|
|
||||||
|
; _ and ... as literals:
|
||||||
|
(define-syntax test-specials (syntax-rules (_ ...) ((_ _ ...) '(_ ...)) ((_ x y) (vector x y))))
|
||||||
|
(test (list (test-specials _ ...) (test-specials 1 2))
|
||||||
|
'((_ ...) #(1 2)))
|
||||||
|
|
||||||
|
|
||||||
(test-end)
|
(test-end)
|
||||||
|
|
|
||||||
190
n.c
190
n.c
|
|
@ -1119,108 +1119,7 @@ void oportputshared(obj x, obj p, int disp) {
|
||||||
stabfree(e.pst);
|
stabfree(e.pst);
|
||||||
}
|
}
|
||||||
|
|
||||||
/* system-dependent extensions */
|
/* S-expression tokenizer */
|
||||||
|
|
||||||
|
|
||||||
extern int is_tty_port(obj o)
|
|
||||||
{
|
|
||||||
FILE *fp = NULL;
|
|
||||||
if ((cxtype_t*)iportvt(o) == IPORT_FILE_NTAG) fp = ((tifile_t*)iportdata(o))->fp;
|
|
||||||
else if ((cxtype_t*)oportvt(o) == OPORT_FILE_NTAG) fp = (FILE*)oportdata(o);
|
|
||||||
if (!fp) return 0;
|
|
||||||
return isatty(fileno(fp));
|
|
||||||
}
|
|
||||||
|
|
||||||
#ifdef WIN32
|
|
||||||
int dirsep = '\\';
|
|
||||||
int pathsep = ';';
|
|
||||||
#else
|
|
||||||
int dirsep = '/';
|
|
||||||
int pathsep = ':';
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#ifdef LIBPATH
|
|
||||||
char *lib_path = ##LIBPATH;
|
|
||||||
#elif defined(WIN32)
|
|
||||||
char *lib_path = ".\\";
|
|
||||||
#else
|
|
||||||
char *lib_path = "./";
|
|
||||||
#endif
|
|
||||||
|
|
||||||
extern char *argv_ref(int idx)
|
|
||||||
{
|
|
||||||
char **pv = cxg_argv;
|
|
||||||
/* be careful with indexing! */
|
|
||||||
if (idx < 0) return NULL;
|
|
||||||
while (idx-- > 0) if (*pv++ == NULL) return NULL;
|
|
||||||
return *pv;
|
|
||||||
}
|
|
||||||
|
|
||||||
#if defined(WIN32)
|
|
||||||
#define cxg_envv _environ
|
|
||||||
#elif defined(__linux)
|
|
||||||
#define cxg_envv environ
|
|
||||||
#elif defined(__APPLE__)
|
|
||||||
extern char **environ;
|
|
||||||
#define cxg_envv environ
|
|
||||||
#else /* add more systems? */
|
|
||||||
char **cxg_envv = { NULL };
|
|
||||||
#endif
|
|
||||||
|
|
||||||
extern char *envv_ref(int idx)
|
|
||||||
{
|
|
||||||
char **pv = cxg_envv;
|
|
||||||
/* be careful with indexing! */
|
|
||||||
if (idx < 0) return NULL;
|
|
||||||
while (idx-- > 0) if (*pv++ == NULL) return NULL;
|
|
||||||
return *pv;
|
|
||||||
}
|
|
||||||
|
|
||||||
extern char *get_cwd(void)
|
|
||||||
{
|
|
||||||
static char buf[FILENAME_MAX]; size_t len;
|
|
||||||
if (getcwd(buf, FILENAME_MAX) == NULL) return NULL;
|
|
||||||
len = strlen(buf);
|
|
||||||
/* if this is a regular path that has internal separators but not at the end, add it */
|
|
||||||
if (len > 0 && len < FILENAME_MAX-1 && strchr(buf, dirsep) && buf[len-1] != dirsep) {
|
|
||||||
buf[len++] = dirsep; buf[len] = 0;
|
|
||||||
}
|
|
||||||
return buf;
|
|
||||||
}
|
|
||||||
|
|
||||||
extern int set_cwd(char *cwd)
|
|
||||||
{
|
|
||||||
return chdir(cwd);
|
|
||||||
}
|
|
||||||
|
|
||||||
#define TT_FALSE 'f'
|
|
||||||
#define TT_TRUE 't'
|
|
||||||
#define TT_NUMBER 'n'
|
|
||||||
#define TT_CHAR 'c'
|
|
||||||
#define TT_STRING 's'
|
|
||||||
#define TT_SYMBOL 'y'
|
|
||||||
#define TT_OPENLIST 'l'
|
|
||||||
#define TT_OPENVEC 'v'
|
|
||||||
#define TT_OPENU8VEC 'u'
|
|
||||||
#define TT_CLOSE 'r'
|
|
||||||
#define TT_OPENLIST2 'b'
|
|
||||||
#define TT_CLOSE2 'k'
|
|
||||||
#define TT_QUOTE '\''
|
|
||||||
#define TT_QQUOTE '`'
|
|
||||||
#define TT_UNQUOTE ','
|
|
||||||
#define TT_UNQSPL '@'
|
|
||||||
#define TT_DOT '.'
|
|
||||||
#define TT_BOX '&'
|
|
||||||
#define TT_HDEF '='
|
|
||||||
#define TT_HREF '#'
|
|
||||||
#define TT_HSEMI ';'
|
|
||||||
#define TT_SHEBANG '!'
|
|
||||||
#define TT_SHEBANG_FC 'F'
|
|
||||||
#define TT_SHEBANG_NF 'N'
|
|
||||||
#define TT_ERR 0
|
|
||||||
#define TT_EOF -1
|
|
||||||
|
|
||||||
#if 1
|
|
||||||
static char num_map[256] = { /* [#A-Za-z/0123456789.@+-] */
|
static char num_map[256] = { /* [#A-Za-z/0123456789.@+-] */
|
||||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||||
0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
|
0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
|
||||||
|
|
@ -1232,15 +1131,7 @@ static char num_map[256] = { /* [#A-Za-z/0123456789.@+-] */
|
||||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||||
};
|
};
|
||||||
#define is_num(c) (num_map[(c) & 0xFF]) /* NB: eof at num_map[255] */
|
#define is_num(c) (num_map[(c) & 0xFF]) /* NB: eof at num_map[255] */
|
||||||
#else
|
|
||||||
static int is_num(int c)
|
|
||||||
{ /* this covers all initials and constituents of prefixed numbers */
|
|
||||||
char *s = "#ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz/0123456789+-.@";
|
|
||||||
return c != EOF && strchr(s, c) != NULL;
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#if 1
|
|
||||||
static char numsym_map[256] = { /* [A-Za-z!$%&*:/<=>?^_~0123456789.@+-] */
|
static char numsym_map[256] = { /* [A-Za-z!$%&*:/<=>?^_~0123456789.@+-] */
|
||||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||||
0, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1,
|
0, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1,
|
||||||
|
|
@ -1252,13 +1143,6 @@ static char numsym_map[256] = { /* [A-Za-z!$%&*:/<=>?^_~0123456789.@+-] */
|
||||||
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
|
||||||
};
|
};
|
||||||
#define is_numsym(c) (numsym_map[(c) & 0xFF]) /* NB: eof at numsym_map[255] */
|
#define is_numsym(c) (numsym_map[(c) & 0xFF]) /* NB: eof at numsym_map[255] */
|
||||||
#else
|
|
||||||
static int is_numsym(int c)
|
|
||||||
{ /* this covers all initials and constituents of plain symbols and nonprefixed decimals */
|
|
||||||
char *s = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!$%&*/:<=>?^_~0123456789+-.@";
|
|
||||||
return c != EOF && strchr(s, c) != NULL;
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
static int is_delimiter(int c)
|
static int is_delimiter(int c)
|
||||||
{
|
{
|
||||||
|
|
@ -1514,3 +1398,75 @@ int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *
|
||||||
return TT_ERR;
|
return TT_ERR;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* system-dependent extensions */
|
||||||
|
|
||||||
|
extern int is_tty_port(obj o)
|
||||||
|
{
|
||||||
|
FILE *fp = NULL;
|
||||||
|
if ((cxtype_t*)iportvt(o) == IPORT_FILE_NTAG) fp = ((tifile_t*)iportdata(o))->fp;
|
||||||
|
else if ((cxtype_t*)oportvt(o) == OPORT_FILE_NTAG) fp = (FILE*)oportdata(o);
|
||||||
|
if (!fp) return 0;
|
||||||
|
return isatty(fileno(fp));
|
||||||
|
}
|
||||||
|
|
||||||
|
#ifdef WIN32
|
||||||
|
int dirsep = '\\';
|
||||||
|
int pathsep = ';';
|
||||||
|
#else
|
||||||
|
int dirsep = '/';
|
||||||
|
int pathsep = ':';
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#ifdef LIBPATH
|
||||||
|
char *lib_path = ##LIBPATH;
|
||||||
|
#elif defined(WIN32)
|
||||||
|
char *lib_path = ".\\";
|
||||||
|
#else
|
||||||
|
char *lib_path = "./";
|
||||||
|
#endif
|
||||||
|
|
||||||
|
extern char *argv_ref(int idx)
|
||||||
|
{
|
||||||
|
char **pv = cxg_argv;
|
||||||
|
/* be careful with indexing! */
|
||||||
|
if (idx < 0) return NULL;
|
||||||
|
while (idx-- > 0) if (*pv++ == NULL) return NULL;
|
||||||
|
return *pv;
|
||||||
|
}
|
||||||
|
|
||||||
|
#if defined(WIN32)
|
||||||
|
#define cxg_envv _environ
|
||||||
|
#elif defined(__linux)
|
||||||
|
#define cxg_envv environ
|
||||||
|
#elif defined(__APPLE__)
|
||||||
|
extern char **environ;
|
||||||
|
#define cxg_envv environ
|
||||||
|
#else /* add more systems? */
|
||||||
|
char **cxg_envv = { NULL };
|
||||||
|
#endif
|
||||||
|
|
||||||
|
extern char *envv_ref(int idx)
|
||||||
|
{
|
||||||
|
char **pv = cxg_envv;
|
||||||
|
/* be careful with indexing! */
|
||||||
|
if (idx < 0) return NULL;
|
||||||
|
while (idx-- > 0) if (*pv++ == NULL) return NULL;
|
||||||
|
return *pv;
|
||||||
|
}
|
||||||
|
|
||||||
|
extern char *get_cwd(void)
|
||||||
|
{
|
||||||
|
static char buf[FILENAME_MAX]; size_t len;
|
||||||
|
if (getcwd(buf, FILENAME_MAX) == NULL) return NULL;
|
||||||
|
len = strlen(buf);
|
||||||
|
/* if this is a regular path that has internal separators but not at the end, add it */
|
||||||
|
if (len > 0 && len < FILENAME_MAX-1 && strchr(buf, dirsep) && buf[len-1] != dirsep) {
|
||||||
|
buf[len++] = dirsep; buf[len] = 0;
|
||||||
|
}
|
||||||
|
return buf;
|
||||||
|
}
|
||||||
|
|
||||||
|
extern int set_cwd(char *cwd)
|
||||||
|
{
|
||||||
|
return chdir(cwd);
|
||||||
|
}
|
||||||
|
|
|
||||||
33
n.h
33
n.h
|
|
@ -96,7 +96,7 @@ extern void cxm_check(int x, char *msg);
|
||||||
extern void *cxm_cknull(void *p, char *msg);
|
extern void *cxm_cknull(void *p, char *msg);
|
||||||
extern int cxg_rc;
|
extern int cxg_rc;
|
||||||
extern char **cxg_argv;
|
extern char **cxg_argv;
|
||||||
|
|
||||||
/* extra definitions */
|
/* extra definitions */
|
||||||
/* basic object representation */
|
/* basic object representation */
|
||||||
#ifdef NAN_BOXING
|
#ifdef NAN_BOXING
|
||||||
|
|
@ -328,6 +328,11 @@ extern int *stringcat(int *d0, int *d1);
|
||||||
extern int *dupstring(int *d);
|
extern int *dupstring(int *d);
|
||||||
extern void stringfill(int *d, int c);
|
extern void stringfill(int *d, int c);
|
||||||
extern int strcmp_ci(char *s1, char *s2);
|
extern int strcmp_ci(char *s1, char *s2);
|
||||||
|
/* tuples */
|
||||||
|
#define TUPLE_BTAG 0
|
||||||
|
#define istuple(o) istagged(o, TUPLE_BTAG)
|
||||||
|
#define tupleref(v, i) *taggedref(v, TUPLE_BTAG, i)
|
||||||
|
#define tuplelen(v) taggedlen(v, TUPLE_BTAG)
|
||||||
/* vectors */
|
/* vectors */
|
||||||
#define VECTOR_BTAG 1
|
#define VECTOR_BTAG 1
|
||||||
#define isvector(o) istagged(o, VECTOR_BTAG)
|
#define isvector(o) istagged(o, VECTOR_BTAG)
|
||||||
|
|
@ -508,4 +513,30 @@ extern void oportputsimple(obj x, obj p, int disp);
|
||||||
extern void oportputcircular(obj x, obj p, int disp);
|
extern void oportputcircular(obj x, obj p, int disp);
|
||||||
extern void oportputshared(obj x, obj p, int disp);
|
extern void oportputshared(obj x, obj p, int disp);
|
||||||
/* S-expression tokenizer */
|
/* S-expression tokenizer */
|
||||||
|
#define TT_FALSE 'f'
|
||||||
|
#define TT_TRUE 't'
|
||||||
|
#define TT_NUMBER 'n'
|
||||||
|
#define TT_CHAR 'c'
|
||||||
|
#define TT_STRING 's'
|
||||||
|
#define TT_SYMBOL 'y'
|
||||||
|
#define TT_OPENLIST 'l'
|
||||||
|
#define TT_OPENVEC 'v'
|
||||||
|
#define TT_OPENU8VEC 'u'
|
||||||
|
#define TT_CLOSE 'r'
|
||||||
|
#define TT_OPENLIST2 'b'
|
||||||
|
#define TT_CLOSE2 'k'
|
||||||
|
#define TT_QUOTE '\''
|
||||||
|
#define TT_QQUOTE '`'
|
||||||
|
#define TT_UNQUOTE ','
|
||||||
|
#define TT_UNQSPL '@'
|
||||||
|
#define TT_DOT '.'
|
||||||
|
#define TT_BOX '&'
|
||||||
|
#define TT_HDEF '='
|
||||||
|
#define TT_HREF '#'
|
||||||
|
#define TT_HSEMI ';'
|
||||||
|
#define TT_SHEBANG '!'
|
||||||
|
#define TT_SHEBANG_FC 'F'
|
||||||
|
#define TT_SHEBANG_NF 'N'
|
||||||
|
#define TT_ERR 0
|
||||||
|
#define TT_EOF -1
|
||||||
extern int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *pcb);
|
extern int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *pcb);
|
||||||
|
|
|
||||||
109
pre/s.scm
109
pre/s.scm
|
|
@ -1520,121 +1520,36 @@
|
||||||
[(k) (read-subbytevector k (current-input-port))]
|
[(k) (read-subbytevector k (current-input-port))]
|
||||||
[(k p) (read-subbytevector k p)]))
|
[(k p) (read-subbytevector k p)]))
|
||||||
|
|
||||||
(define %read
|
(define %read ; uses %read-datum / %read-datum-error-string instructions
|
||||||
(body
|
(body
|
||||||
; support for sharing (use procedures that can't be read)
|
(define (shared-ref? form) (tuple? form 1))
|
||||||
(define (make-shared-ref loc) (lambda () (unbox loc)))
|
(define (patch-ref! form) (if (tuple? form 1) (patch-ref! (tuple-ref form 0)) form))
|
||||||
(define (shared-ref? form) (procedure? form))
|
|
||||||
(define (patch-ref! form) (if (procedure? form) (patch-ref! (form)) form))
|
|
||||||
(define (patch-shared! form)
|
(define (patch-shared! form)
|
||||||
(cond [(pair? form)
|
(cond [(pair? form)
|
||||||
(if (procedure? (car form))
|
(if (shared-ref? (car form))
|
||||||
(set-car! form (patch-ref! (car form)))
|
(set-car! form (patch-ref! (car form)))
|
||||||
(patch-shared! (car form)))
|
(patch-shared! (car form)))
|
||||||
(if (procedure? (cdr form))
|
(if (shared-ref? (cdr form))
|
||||||
(set-cdr! form (patch-ref! (cdr form)))
|
(set-cdr! form (patch-ref! (cdr form)))
|
||||||
(patch-shared! (cdr form)))]
|
(patch-shared! (cdr form)))]
|
||||||
[(vector? form)
|
[(vector? form)
|
||||||
(let loop ([i 0])
|
(let loop ([i 0])
|
||||||
(when (fx<? i (vector-length form))
|
(when (fx<? i (vector-length form))
|
||||||
(let ([fi (vector-ref form i)])
|
(let ([fi (vector-ref form i)])
|
||||||
(if (procedure? fi)
|
(if (shared-ref? fi)
|
||||||
(vector-set! form i (patch-ref! fi))
|
(vector-set! form i (patch-ref! fi))
|
||||||
(patch-shared! fi)))
|
(patch-shared! fi)))
|
||||||
(loop (fx+ i 1))))]
|
(loop (fx+ i 1))))]
|
||||||
[(box? form)
|
[(box? form)
|
||||||
(if (procedure? (unbox form))
|
(if (shared-ref? (unbox form))
|
||||||
(set-box! form (patch-shared! (unbox form)))
|
(set-box! form (patch-shared! (unbox form)))
|
||||||
(patch-shared! (unbox form)))]))
|
(patch-shared! (unbox form)))]))
|
||||||
(define (patch-shared form) (patch-shared! form) form)
|
|
||||||
; special tokens (can't be read, but different from procedures)
|
|
||||||
(define close-paren (make-record 'token 1 "right parenthesis"))
|
|
||||||
(define close-bracket (make-record 'token 1 "right bracket"))
|
|
||||||
(define dot (make-record 'token 1 "\" . \""))
|
|
||||||
(define-syntax reader-token? record?)
|
|
||||||
(define-syntax reader-token-name (syntax-lambda (x) (record-ref x 0)))
|
|
||||||
; main entry point
|
|
||||||
(lambda (port simple? ci?)
|
(lambda (port simple? ci?)
|
||||||
(define fold-case? (or ci? (port-fold-case? port)))
|
(define shared (if simple? #f '()))
|
||||||
(define buf (open-output-string))
|
(let* ([x (%read-datum port (set& shared))] [es (%read-datum-error-string x)])
|
||||||
(define-syntax r-error
|
(cond [es (read-error es port)]
|
||||||
(syntax-rules () [(_ msg a ...) (read-error msg a ... 'port: port)]))
|
[(pair? shared) (patch-shared! x) x]
|
||||||
(define shared '())
|
[else x])))))
|
||||||
(define (sub-read)
|
|
||||||
(let ([tk (%read-token port buf)])
|
|
||||||
(cond [(eq? tk #t) (eof-object)]
|
|
||||||
[(eq? tk #f) (r-error "invalid token")]
|
|
||||||
[(char=? tk #\f) #f]
|
|
||||||
[(char=? tk #\t) #t]
|
|
||||||
[(char=? tk #\n)
|
|
||||||
(or (%get-output-value buf #\n)
|
|
||||||
(read-error "unsupported number syntax (implementation restriction)"
|
|
||||||
(get-output-string buf)))]
|
|
||||||
[(char=? tk #\y)
|
|
||||||
(if fold-case?
|
|
||||||
(string-ci->symbol (get-output-string buf))
|
|
||||||
(%get-output-value buf #\y))]
|
|
||||||
[(or (char=? tk #\c) (char=? tk #\s) (char=? tk #\!)) (%get-output-value buf tk)]
|
|
||||||
[(char=? tk #\;) (sub-read-carefully) (sub-read)]
|
|
||||||
[(char=? tk #\l) (sub-read-list close-paren #t #f)]
|
|
||||||
[(char=? tk #\v) (list->vector (sub-read-list close-paren #f #f))]
|
|
||||||
[(char=? tk #\u) (list->bytevector (sub-read-list close-paren #f #t))]
|
|
||||||
[(char=? tk #\r) close-paren]
|
|
||||||
[(char=? tk #\b) (sub-read-list close-bracket #t #f)]
|
|
||||||
[(char=? tk #\k) close-bracket]
|
|
||||||
[(char=? tk #\.) dot]
|
|
||||||
[(char=? tk #\') (list 'quote (sub-read-carefully))]
|
|
||||||
[(char=? tk #\`) (list 'quasiquote (sub-read-carefully))]
|
|
||||||
[(char=? tk #\,) (list 'unquote (sub-read-carefully))]
|
|
||||||
[(char=? tk #\@) (list 'unquote-splicing (sub-read-carefully))]
|
|
||||||
[(char=? tk #\&) (box (sub-read-carefully))]
|
|
||||||
[(or (char=? tk #\F) (char=? tk #\N))
|
|
||||||
(set! fold-case? (char=? tk #\F))
|
|
||||||
(set-port-fold-case! port fold-case?)
|
|
||||||
(sub-read)]
|
|
||||||
[(or (char=? tk #\#) (char=? tk #\=))
|
|
||||||
(when simple? (r-error "#N=/#N# notation is not allowed in this mode"))
|
|
||||||
(let ([n (%get-output-value buf #\n)])
|
|
||||||
(if (char=? tk #\#)
|
|
||||||
(cond [(and (fixnum? n) (assq n shared)) => cdr]
|
|
||||||
[else (r-error "unknown #n# reference" n)])
|
|
||||||
(cond [(not (fixnum? n)) (r-error "invalid #n= reference" n)]
|
|
||||||
[(assq n shared) (r-error "duplicate #n= tag:" n)]
|
|
||||||
[else
|
|
||||||
(let ([loc (box #f)])
|
|
||||||
(set! shared (cons (cons n (make-shared-ref loc)) shared))
|
|
||||||
(let ([form (sub-read-carefully)])
|
|
||||||
(cond [(shared-ref? form) (r-error "#n= has a label as target" n)]
|
|
||||||
[else (set-box! loc form) form])))])))]
|
|
||||||
[else (r-error "invalid token" tk (get-output-string buf))])))
|
|
||||||
(define (sub-read-carefully)
|
|
||||||
(let ([form (sub-read)])
|
|
||||||
(cond [(eof-object? form)
|
|
||||||
(r-error "unexpected end of file")]
|
|
||||||
[(reader-token? form) ; special reader token
|
|
||||||
(r-error (string-append "unexpected token: " (reader-token-name form)))]
|
|
||||||
[else form])))
|
|
||||||
(define (sub-read-list close-token dot? byte?)
|
|
||||||
(let loop ([form (sub-read)] [l #f] [lp #f])
|
|
||||||
(cond [(eof-object? form) (r-error "eof inside list -- unbalanced parentheses")]
|
|
||||||
[(eq? form close-token) (if lp l '())]
|
|
||||||
[(and dot? (eq? form dot))
|
|
||||||
(let* ([form (sub-read-carefully)] [another-form (sub-read)])
|
|
||||||
(if (eq? another-form close-token)
|
|
||||||
(cond [lp (set-cdr! lp form) l] [else (r-error "unexpected dot")])
|
|
||||||
(r-error "too many forms after dot" another-form)))]
|
|
||||||
[(eq? form dot) (r-error "unexpected dot notation")]
|
|
||||||
[(reader-token? form) ; other special reader token
|
|
||||||
(r-error (string-append "unexpected token: " (reader-token-name form)))]
|
|
||||||
[(and byte? (or (not (fixnum? form)) (fx<? form 0) (fx>? form 255)))
|
|
||||||
(r-error "invalid byte inside bytevector" form)]
|
|
||||||
[(not lp) (let ([l (list form)]) (loop (sub-read) l l))]
|
|
||||||
[else (let ([nlp (list form)]) (set-cdr! lp nlp) (loop (sub-read) l nlp))])))
|
|
||||||
; body of %read
|
|
||||||
(let ([form (sub-read)])
|
|
||||||
(if (not (reader-token? form))
|
|
||||||
(if (null? shared) form (patch-shared form))
|
|
||||||
(r-error (string-append "unexpected token: " (reader-token-name form))))))))
|
|
||||||
|
|
||||||
(define read
|
(define read
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
|
|
||||||
|
|
@ -2758,7 +2758,7 @@
|
||||||
[help "-h" "--help" #f "Display this help"]
|
[help "-h" "--help" #f "Display this help"]
|
||||||
))
|
))
|
||||||
|
|
||||||
(define *skint-version* "0.6.2")
|
(define *skint-version* "0.6.3")
|
||||||
|
|
||||||
(define (implementation-version) *skint-version*)
|
(define (implementation-version) *skint-version*)
|
||||||
(define (implementation-name) "SKINT")
|
(define (implementation-name) "SKINT")
|
||||||
|
|
|
||||||
54
s.c
54
s.c
|
|
@ -836,53 +836,13 @@ char *s_code[] = {
|
||||||
"tevector)[12}%x,&2{|10|21%%}@!(y15:read-bytevector)",
|
"tevector)[12}%x,&2{|10|21%%}@!(y15:read-bytevector)",
|
||||||
|
|
||||||
"C", 0,
|
"C", 0,
|
||||||
",,,,,,,,#0#1#2#3#4#5#6#7&0{%1.0,&1{%0:0z]0}]1}.!0&0{%1.0K0]1}.!1.2,&1{"
|
",,,#0#1#2&0{%1'1,.1O7]1}.!0.1,&1{%1'1,.1O7?{'0,.1O9,:0^[11}.0]1}.!1.0,"
|
||||||
"%1.0K0?{${.2[00},:0^[11}.0]1}.!2.3,.3,&2{%1.0p?{.0aK0?{${.2a,:0^[01},."
|
".3,.3,&3{%1.0p?{${.2a,:2^[01}?{${.2a,:0^[01},.1sa}{${.2a,:1^[01}}${.2d"
|
||||||
"1sa}{${.2a,:1^[01}}.0dK0?{${.2d,:0^[01},.1sd]1}.0d,:1^[11}.0V0?{'0,,#0"
|
",:2^[01}?{${.2d,:0^[01},.1sd]1}.0d,:1^[11}.0V0?{'0,,#0.2,:2,:0,:1,.4,&"
|
||||||
".2,:0,:1,.3,&4{%1:3V3,.1I<?{.0,:3V4,.0K0?{${.2,:2^[01},.2,:3V5}{${.2,:"
|
"5{%1:4V3,.1I<?{.0,:4V4,${.2,:3^[01}?{${.2,:2^[01},.2,:4V5}{${.2,:1^[01"
|
||||||
"1^[01}}_1'1,.1I+,:0^[11}]1}.!0.0^_1[11}.0Y2?{.0zK0?{${.2z,:1^[01},.1sz"
|
"}}_1'1,.1I+,:0^[11}]1}.!0.0^_1[11}.0Y2?{${.2z,:2^[01}?{${.2z,:1^[01},."
|
||||||
"]1}.0z,:1^[11}f]1}.!3.3,&1{%1${.2,:0^[01}.0]1}.!4'(s17:right parenthes"
|
"1sz]1}.0z,:1^[11}f]1}.!2.2,&1{%3,#0.2?{f}{n}.!0.0,.2Rd,.0Re,.0?{.3,.1,"
|
||||||
"is),'1,'(y5:token)O2.!5'(s13:right bracket),'1,'(y5:token)O2.!6'(s5:%2"
|
"@(y10:read-error)[62}.2^p?{${.3,:0^[01}.1]6}.1]6}_3@!(y5:%25read)",
|
||||||
"2 . %22),'1,'(y5:token)O2.!7.5,.7,.2,.4,.(i11),.9,&6{%3,,,,,,#0#1#2#3#"
|
|
||||||
"4#5.8,.0?{.0}{.7P78}_1.!0P51.!1n.!2.6,.2,:5,.8,:4,:1,.9,.7,.(i10),:3,."
|
|
||||||
"(i14),:2,.(i19),&(i13){%0:(i11)^,:(i12)R7,t,.1q?{R9]1}f,.1q?{:(i12),'("
|
|
||||||
"y5:port:),'(s13:invalid token),@(y10:read-error)[13}'(cf),.1C=?{f]1}'("
|
|
||||||
"ct),.1C=?{t]1}'(cn),.1C=?{'(cn),:(i11)^P92,.0?{.0]2}:(i11)^P90,'(s54:u"
|
|
||||||
"nsupported number syntax (implementation restriction)),@(y10:read-erro"
|
|
||||||
"r)[22}'(cy),.1C=?{:5^?{:(i11)^P90,@(y17:string-ci->symbol)[11}'(cy),:("
|
|
||||||
"i11)^P92]1}'(cc),.1C=,.0?{.0}{'(cs),.2C=,.0?{.0}{'(c!),.3C=}_1}_1?{.0,"
|
|
||||||
":(i11)^P92]1}'(c;),.1C=?{${:2^[00}:6^[10}'(cl),.1C=?{f,t,:(i10)^,:9^[1"
|
|
||||||
"3}'(cv),.1C=?{${f,f,:(i10)^,:9^[03}X1]1}'(cu),.1C=?{${t,f,:(i10)^,:9^["
|
|
||||||
"03}E1]1}'(cr),.1C=?{:(i10)^]1}'(cb),.1C=?{f,t,:8^,:9^[13}'(ck),.1C=?{:"
|
|
||||||
"8^]1}'(c.),.1C=?{:7^]1}'(c'),.1C=?{${:2^[00},'(y5:quote),l2]1}'(c`),.1"
|
|
||||||
"C=?{${:2^[00},'(y10:quasiquote),l2]1}'(c,),.1C=?{${:2^[00},'(y7:unquot"
|
|
||||||
"e),l2]1}'(c@),.1C=?{${:2^[00},'(y16:unquote-splicing),l2]1}'(c&),.1C=?"
|
|
||||||
"{${:2^[00}b]1}'(cF),.1C=,.0?{.0}{'(cN),.2C=}_1?{'(cF),.1C=:!5:5^,:(i12"
|
|
||||||
")P79:6^[10}'(c#),.1C=,.0?{.0}{'(c=),.2C=}_1?{:0?{${:(i12),'(y5:port:),"
|
|
||||||
"'(s44:#N=/#N# notation is not allowed in this mode),@(y10:read-error)["
|
|
||||||
"03}}'(cn),:(i11)^P92,'(c#),.2C=?{.0I0?{:4^,.1A3}{f},.0?{.0d]3}:(i12),'"
|
|
||||||
"(y5:port:),.3,'(s21:unknown #n# reference),@(y10:read-error)[34}.0I0~?"
|
|
||||||
"{:(i12),'(y5:port:),.2,'(s21:invalid #n= reference),@(y10:read-error)["
|
|
||||||
"24}:4^,.1A3?{:(i12),'(y5:port:),.2,'(s18:duplicate #n= tag:),@(y10:rea"
|
|
||||||
"d-error)[24}fb,:4^,${.3,:3^[01},.3cc:!4${:2^[00},${.2,:1^[01}?{:(i12),"
|
|
||||||
"'(y5:port:),.4,'(s25:#n= has a label as target),@(y10:read-error)[44}."
|
|
||||||
"0,.2sz.0]4}:(i12),'(y5:port:),:(i11)^P90,.3,'(s13:invalid token),@(y10"
|
|
||||||
":read-error)[15}.!3.3,.7,&2{%0${:1^[00},.0R8?{:0,'(y5:port:),'(s22:une"
|
|
||||||
"xpected end of file),@(y10:read-error)[13}Y9,.1O0?{:0,'(y5:port:),'0,."
|
|
||||||
"3O4,'(s18:unexpected token: ),Sa2,@(y10:read-error)[13}.0]1}.!4.3,.5,:"
|
|
||||||
"1,.9,&4{%3f,f,${:3^[00},,#0:3,.1,:0,.9,:1,.9,:2,.(i12),&8{%3.0R8?{:5,'"
|
|
||||||
"(y5:port:),'(s41:eof inside list -- unbalanced parentheses),@(y10:read"
|
|
||||||
"-error)[33}:2,.1q?{.2?{.1]3}n]3}:0?{:3^,.1q}{f}?{${:1^[00},${:7^[00},:"
|
|
||||||
"2,.1q?{.4?{.1,.5sd.3]5}:5,'(y5:port:),'(s14:unexpected dot),@(y10:read"
|
|
||||||
"-error)[53}:5,'(y5:port:),.2,'(s24:too many forms after dot),@(y10:rea"
|
|
||||||
"d-error)[54}:3^,.1q?{:5,'(y5:port:),'(s23:unexpected dot notation),@(y"
|
|
||||||
"10:read-error)[33}Y9,.1O0?{:5,'(y5:port:),'0,.3O4,'(s18:unexpected tok"
|
|
||||||
"en: ),Sa2,@(y10:read-error)[33}:4?{.0I0~,.0?{.0}{'0,.2I<,.0?{.0}{'(i25"
|
|
||||||
"5),.3I>}_1}_1}{f}?{:5,'(y5:port:),.2,'(s30:invalid byte inside bytevec"
|
|
||||||
"tor),@(y10:read-error)[34}.2~?{.0,l1,.0,.1,${:7^[00},:6^[43}.0,l1,.0,."
|
|
||||||
"4sd.0,.3,${:7^[00},:6^[43}.!0.0^_1[33}.!5${.5^[00},Y9,.1O0~?{.3^u?{.0]"
|
|
||||||
"(i10)}.0,:0^[(i10)1}.7,'(y5:port:),'0,.3O4,'(s18:unexpected token: ),S"
|
|
||||||
"a2,@(y10:read-error)[(i10)3}_8@!(y5:%25read)",
|
|
||||||
|
|
||||||
"C", 0,
|
"C", 0,
|
||||||
"&0{%1f,f,.2,@(y5:%25read)[13}%x,&0{%0f,f,Pi,@(y5:%25read)[03}%x,&2{|00"
|
"&0{%1f,f,.2,@(y5:%25read)[13}%x,&0{%0f,f,Pi,@(y5:%25read)[03}%x,&2{|00"
|
||||||
|
|
|
||||||
2
t.c
2
t.c
|
|
@ -1736,7 +1736,7 @@ char *t_code[] = {
|
||||||
"kint-options*)",
|
"kint-options*)",
|
||||||
|
|
||||||
"C", 0,
|
"C", 0,
|
||||||
"'(s5:0.6.2)@!(y15:*skint-version*)",
|
"'(s5:0.6.3)@!(y15:*skint-version*)",
|
||||||
|
|
||||||
"P", "implementation-version",
|
"P", "implementation-version",
|
||||||
"%0@(y15:*skint-version*)]0",
|
"%0@(y15:*skint-version*)]0",
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue