faster read, minor fixes

This commit is contained in:
ESL 2024-10-21 15:12:19 -04:00
parent 74d652f3d9
commit 8d8721892e
10 changed files with 404 additions and 271 deletions

267
i.c
View file

@ -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_stoc(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 */
#if defined(__clang__)
@ -159,9 +164,6 @@ static int istagged_inline(obj o, int t) { return isobjptr(o) && hblkref(o, 0) =
#endif
/* 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 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 proc_len(o) vmclolen(o)
#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_ref(o, i) tupleref(o, i)
#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)
#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)
#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))) \
{ 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))) \
@ -1550,6 +1554,36 @@ define_instruction(rrtd) {
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) {
ac = bool_obj(is_vector(ac));
@ -3492,6 +3526,34 @@ define_instruction(rdtk) {
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) {
ac = bool_obj(is_eof(ac));
gonexti();
@ -3502,7 +3564,6 @@ define_instruction(eof) {
gonexti();
}
define_instruction(wrc) {
obj x = ac, y = spop(); ckc(x); ckw(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 */
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;
int c = iportgetc(port);
@ -4790,7 +4851,6 @@ static obj *rds_stoc(obj *r, obj *sp, obj *hp)
return hp;
}
/* protects registers from r to sp */
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);
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
View file

@ -443,6 +443,9 @@ declare_instruction(rlen, "O3", 0, "record-length",
declare_instruction(rget, "O4", 0, "record-ref", '2', AUTOGL)
declare_instruction(rput, "O5", 0, "record-set!", '3', 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(ltov, "X1", 0, "list->vector", '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(rdln, "R6\0Pi", 0, "read-line", 'u', 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(eof, "R9", 0, "eof-object", '0', AUTOGL)
declare_instruction(wrc, "W0\0Po", 0, "write-char", 'b', AUTOGL)

View file

@ -1 +1,4 @@
(import (only (skint) implementation-version))

View file

@ -3076,4 +3076,12 @@
(test (write-data write-simple '(#() #(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)

190
n.c
View file

@ -1119,108 +1119,7 @@ void oportputshared(obj x, obj p, int disp) {
stabfree(e.pst);
}
/* 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);
}
#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
/* S-expression tokenizer */
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, 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,
};
#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.@+-] */
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,
@ -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,
};
#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)
{
@ -1514,3 +1398,75 @@ int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *
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);
}

31
n.h
View file

@ -328,6 +328,11 @@ 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);
/* 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 */
#define VECTOR_BTAG 1
#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 oportputshared(obj x, obj p, int disp);
/* 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);

109
pre/s.scm
View file

@ -1520,121 +1520,36 @@
[(k) (read-subbytevector k (current-input-port))]
[(k p) (read-subbytevector k p)]))
(define %read
(define %read ; uses %read-datum / %read-datum-error-string instructions
(body
; support for sharing (use procedures that can't be read)
(define (make-shared-ref loc) (lambda () (unbox loc)))
(define (shared-ref? form) (procedure? form))
(define (patch-ref! form) (if (procedure? form) (patch-ref! (form)) form))
(define (shared-ref? form) (tuple? form 1))
(define (patch-ref! form) (if (tuple? form 1) (patch-ref! (tuple-ref form 0)) form))
(define (patch-shared! form)
(cond [(pair? form)
(if (procedure? (car form))
(if (shared-ref? (car form))
(set-car! form (patch-ref! (car form)))
(patch-shared! (car form)))
(if (procedure? (cdr form))
(if (shared-ref? (cdr form))
(set-cdr! form (patch-ref! (cdr form)))
(patch-shared! (cdr form)))]
[(vector? form)
(let loop ([i 0])
(when (fx<? i (vector-length form))
(let ([fi (vector-ref form i)])
(if (procedure? fi)
(if (shared-ref? fi)
(vector-set! form i (patch-ref! fi))
(patch-shared! fi)))
(loop (fx+ i 1))))]
[(box? form)
(if (procedure? (unbox form))
(if (shared-ref? (unbox form))
(set-box! 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?)
(define fold-case? (or ci? (port-fold-case? port)))
(define buf (open-output-string))
(define-syntax r-error
(syntax-rules () [(_ msg a ...) (read-error msg a ... 'port: port)]))
(define shared '())
(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 shared (if simple? #f '()))
(let* ([x (%read-datum port (set& shared))] [es (%read-datum-error-string x)])
(cond [es (read-error es port)]
[(pair? shared) (patch-shared! x) x]
[else x])))))
(define read
(case-lambda

View file

@ -2758,7 +2758,7 @@
[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-name) "SKINT")

54
s.c
View file

@ -836,53 +836,13 @@ char *s_code[] = {
"tevector)[12}%x,&2{|10|21%%}@!(y15:read-bytevector)",
"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{"
"%1.0K0?{${.2[00},:0^[11}.0]1}.!2.3,.3,&2{%1.0p?{.0aK0?{${.2a,:0^[01},."
"1sa}{${.2a,:1^[01}}.0dK0?{${.2d,:0^[01},.1sd]1}.0d,:1^[11}.0V0?{'0,,#0"
".2,:0,:1,.3,&4{%1:3V3,.1I<?{.0,:3V4,.0K0?{${.2,:2^[01},.2,:3V5}{${.2,:"
"1^[01}}_1'1,.1I+,:0^[11}]1}.!0.0^_1[11}.0Y2?{.0zK0?{${.2z,:1^[01},.1sz"
"]1}.0z,:1^[11}f]1}.!3.3,&1{%1${.2,:0^[01}.0]1}.!4'(s17:right parenthes"
"is),'1,'(y5:token)O2.!5'(s13:right bracket),'1,'(y5:token)O2.!6'(s5:%2"
"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)",
",,,#0#1#2&0{%1'1,.1O7]1}.!0.1,&1{%1'1,.1O7?{'0,.1O9,:0^[11}.0]1}.!1.0,"
".3,.3,&3{%1.0p?{${.2a,:2^[01}?{${.2a,:0^[01},.1sa}{${.2a,:1^[01}}${.2d"
",:2^[01}?{${.2d,:0^[01},.1sd]1}.0d,:1^[11}.0V0?{'0,,#0.2,:2,:0,:1,.4,&"
"5{%1:4V3,.1I<?{.0,:4V4,${.2,:3^[01}?{${.2,:2^[01},.2,:4V5}{${.2,:1^[01"
"}}_1'1,.1I+,:0^[11}]1}.!0.0^_1[11}.0Y2?{${.2z,:2^[01}?{${.2z,:1^[01},."
"1sz]1}.0z,:1^[11}f]1}.!2.2,&1{%3,#0.2?{f}{n}.!0.0,.2Rd,.0Re,.0?{.3,.1,"
"@(y10:read-error)[62}.2^p?{${.3,:0^[01}.1]6}.1]6}_3@!(y5:%25read)",
"C", 0,
"&0{%1f,f,.2,@(y5:%25read)[13}%x,&0{%0f,f,Pi,@(y5:%25read)[03}%x,&2{|00"

2
t.c
View file

@ -1736,7 +1736,7 @@ char *t_code[] = {
"kint-options*)",
"C", 0,
"'(s5:0.6.2)@!(y15:*skint-version*)",
"'(s5:0.6.3)@!(y15:*skint-version*)",
"P", "implementation-version",
"%0@(y15:*skint-version*)]0",