Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-25 21:58:54 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

faster read

Browse source
This commit is contained in:
ESL 2024-08-29 17:54:17 -04:00
parent c856b07b17
commit 5285131672
10 changed files with 1375 additions and 773 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

153
i.c
View file

@ -13,8 +13,6 @@ extern obj cx__2Acurrent_2Dinput_2A;
extern obj cx__2Acurrent_2Doutput_2A;
extern obj cx__2Acurrent_2Derror_2A;
//#define istagged(o, t) istagged_inlined(o, t)
/* forwards */
static struct intgtab_entry *lookup_integrable(int sym);
static int intgtab_count(void);
@ -269,8 +267,10 @@ static void _sck(obj *s) {
#define is_bytevector(o) isbytevector(o)
#define bytevector_len(o) bytevectorlen(o)
#define bytevector_ref(o, i) (*bytevectorref(o, i))
#define iport_file_obj(fp) hp_pushptr((fp), IPORT_FILE_NTAG)
#define iport_file_obj(fp) hp_pushptr(tialloc(fp), IPORT_FILE_NTAG)
#define iport_bytefile_obj(fp) hp_pushptr((fp), IPORT_BYTEFILE_NTAG)
#define oport_file_obj(fp) hp_pushptr((fp), OPORT_FILE_NTAG)
#define oport_bytefile_obj(fp) hp_pushptr((fp), OPORT_BYTEFILE_NTAG)
#define iport_string_obj(fp) hp_pushptr((fp), IPORT_STRING_NTAG)
#define oport_string_obj(fp) hp_pushptr((fp), OPORT_STRING_NTAG)
#define iport_bytevector_obj(fp) hp_pushptr((fp), IPORT_BYTEVECTOR_NTAG)
@ -1293,9 +1293,11 @@ define_instruction(strp) {
}
define_instruction(str) {
int i, n = get_fixnum(*ip++);
obj o = string_obj(allocstring(n, ' '));
unsigned char *s = (unsigned char *)stringchars(o);
int i, n; obj o = *ip++; unsigned char *s;
/* special arrangement for handcoded proc */
if (!o) o = ac; n = get_fixnum(o);
o = string_obj(allocstring(n, ' '));
s = (unsigned char *)stringchars(o);
for (i = 0; i < n; ++i) {
obj x = sref(i); ckc(x); s[i] = get_char(x);
}
@ -1335,8 +1337,27 @@ define_instruction(sput) {
gonexti();
}
define_instruction(scat) {
obj x = ac, y = spop(); int *d;
define_instruction(sapp) {
int a, c, i, n, *d; obj o = *ip++;
/* special arrangement for handcoded proc */
if (!o) o = ac; c = get_fixnum(o);
for (n = 0, a = 0; a < c; ++a) {
obj s = sref(a); cks(s);
n += string_len(s);
}
d = allocstring(n, ' ');
for (i = 0, a = 0; a < c; ++a) {
obj s = sref(a); n = string_len(s);
memcpy(sdatachars(d)+i, stringchars(s), n);
i += n;
}
sdrop(c); ac = string_obj(d);
gonexti();
}
define_instruction(sapp2) {
/* specialized version of sapp; both args on stack */
obj x = spop(), y = spop(); int *d;
cks(x); cks(y);
d = stringcat(stringdata(x), stringdata(y));
ac = string_obj(d);
@ -1398,9 +1419,11 @@ define_instruction(bvecp) {
}
define_instruction(bvec) {
int i, n = get_fixnum(*ip++);
obj o = bytevector_obj(allocbytevector(n));
unsigned char *s = (unsigned char *)bytevectorbytes(o);
int i, n; obj o = *ip++; unsigned char *s;
/* special arrangement for handcoded proc */
if (!o) o = ac; n = get_fixnum(o);
o = bytevector_obj(allocbytevector(n));
s = (unsigned char *)bytevectorbytes(o);
for (i = 0; i < n; ++i) {
obj x = sref(i); ck8(x); s[i] = byte_from_obj(x);
}
@ -1451,6 +1474,25 @@ define_instruction(bsub) {
gonexti();
}
define_instruction(bapp) {
int a, c, i, n, *d; obj o = *ip++;
/* special arrangement for handcoded proc */
if (!o) o = ac; c = get_fixnum(o);
for (n = 0, a = 0; a < c; ++a) {
obj b = sref(a); ckb(b);
n += bytevector_len(b);
}
d = allocbytevector(n);
for (i = 0, a = 0; a < c; ++a) {
obj b = sref(a); n = bytevector_len(b);
memcpy(bvdatabytes(d)+i, bytevectorbytes(b), n);
i += n;
}
sdrop(c); ac = bytevector_obj(d);
gonexti();
}
define_instruction(beq) {
obj x = ac, y = spop(); ckb(x); ckb(y);
ac = bool_obj(bytevectoreq(bytevectordata(x), bytevectordata(y)));
@ -1515,7 +1557,9 @@ define_instruction(vecp) {
}
define_instruction(vec) {
int i, n = get_fixnum(*ip++);
int i, n; obj o = *ip++;
/* special arrangement for handcoded proc */
if (!o) o = ac; n = get_fixnum(o);
hp_reserve(vecbsz(n));
for (i = n-1; i >= 0; --i) *--hp = sref(i);
ac = hend_vec(n);
@ -1557,8 +1601,27 @@ define_instruction(vput) {
gonexti();
}
define_instruction(vcat) {
obj x = ac, y = sref(0); int n1, n2, n;
define_instruction(vapp) {
int a, c, n, i; obj o = *ip++;
/* special arrangement for handcoded proc */
if (!o) o = ac; c = get_fixnum(o);
for (n = 0, a = 0; a < c; ++a) {
obj v = sref(a); ckv(v);
n += vector_len(v);
}
hp_reserve(vecbsz(n));
for (a = c; a > 0; --a) {
obj v = sref(a-1); i = vector_len(v);
/* NB: vector_ref fails to return pointer to empty vector's start */
hp -= i; if (i) objcpy(hp, &vector_ref(v, 0), i);
}
sdrop(c); ac = hend_vec(n);
gonexti();
}
define_instruction(vapp2) {
/* specialized version of sapp; both args on stack */
obj x = sref(0), y = sref(1); int n1, n2, n;
ckv(x); ckv(y);
n1 = vector_len(x), n2 = vector_len(y), n = n1 + n2;
hp_reserve(vecbsz(n));
@ -1566,7 +1629,7 @@ define_instruction(vcat) {
hp -= n2; if (n2) objcpy(hp, &vector_ref(y, 0), n2);
hp -= n1; if (n1) objcpy(hp, &vector_ref(x, 0), n1);
ac = hend_vec(n);
sdrop(1);
sdrop(2);
gonexti();
}
@ -1619,11 +1682,14 @@ define_instruction(stol) {
}
define_instruction(ltos) {
obj l = ac; int n = 0, i, *d;
while (is_pair(l)) { l = pair_cdr(l); ++n; }
obj l; int n, i, *d;
for (n = 0, l = ac; is_pair(l); l = pair_cdr(l)) {
obj x = pair_car(ac); ckc(x);
++n;
}
d = allocstring(n, ' ');
for (i = 0; i < n; ac = pair_cdr(ac), ++i) {
obj x = pair_car(ac); ckc(x);
obj x = pair_car(ac);
sdatachars(d)[i] = get_char(x);
}
ac = string_obj(d);
@ -3237,14 +3303,14 @@ define_instruction(oof) {
define_instruction(obif) {
FILE *fp; cks(ac);
fp = fopen(stringchars(ac), "rb");
ac = (fp == NULL) ? bool_obj(0) : iport_file_obj(fp);
ac = (fp == NULL) ? bool_obj(0) : iport_bytefile_obj(fp);
gonexti();
}
define_instruction(obof) {
FILE *fp; cks(ac);
fp = fopen(stringchars(ac), "wb");
ac = (fp == NULL) ? bool_obj(0) : oport_file_obj(fp);
ac = (fp == NULL) ? bool_obj(0) : oport_bytefile_obj(fp);
gonexti();
}
@ -3310,7 +3376,6 @@ define_instruction(spfc) {
gonexti();
}
define_instruction(gos) {
cxtype_oport_t *vt; ckw(ac);
vt = ckoportvt(ac);
@ -3320,6 +3385,7 @@ define_instruction(gos) {
} else {
cbuf_t *pcb = oportdata(ac);
ac = string_obj(newstring(cbdata(pcb)));
cbclear(pcb); /* a-la Chez */
}
gonexti();
}
@ -3338,6 +3404,30 @@ define_instruction(gob) {
gonexti();
}
define_instruction(gov) {
obj c = spop(); cxtype_oport_t *vt = oportvt(ac);
int tk; char *s; ckc(c); tk = get_char(c);
if (vt != (cxtype_oport_t *)OPORT_STRING_NTAG) failactype("string input port");
s = cbdata((cbuf_t*)oportdata(ac));
switch (tk) {
case 'n': {
int radix = 10; long l; double d;
switch (strtofxfl(s, radix, &l, &d)) {
case 'e': ac = fixnum_obj(l); break;
case 'i': ac = flonum_obj(d); break;
default : ac = bool_obj(0); break;
}
} break;
case 'c': ac = char_obj(*s); break;
case 'y': ac = mksymbol(internsym(s)); break;
case 's': ac = string_obj(newstring(s)); break;
case '#': case '=': ac = fixnum_obj(atoi(s)); break;
case '!': ac = mkshebang(internsym(s)); break;
default : ac = bool_obj(0);
}
gonexti();
}
define_instruction(rdc) {
int c; ckr(ac);
c = iportgetc(ac);
@ -3382,6 +3472,25 @@ define_instruction(rd8r) {
gonexti();
}
define_instruction(rdln) {
int *d = NULL; cxtype_iport_t *vt = iportvt(ac);
if (!vt || vt->ctl(CTLOP_RDLN, iportdata(ac), &d) < 0) failactype("text input port");
else if (d == NULL) ac = eof_obj();
else ac = string_obj(d);
gonexti();
}
define_instruction(rdtk) {
obj o = spop(); cbuf_t *pcb; int tk;
cxtype_iport_t *ivt = iportvt(ac);
cxtype_oport_t *bvt = oportvt(o);
if (!ivt) failactype("text input port");
if (bvt != (cxtype_oport_t *)OPORT_STRING_NTAG) failtype(o, "string output port");
pcb = oportdata(o);
tk = slex(ivt->getch, ivt->ungetch, iportdata(ac), pcb);
ac = (tk <= 0) ? bool_obj(tk < 0) : char_obj(tk);
gonexti();
}
define_instruction(eofp) {
ac = bool_obj(is_eof(ac));
@ -4015,7 +4124,7 @@ define_instruction(gccnt) {
}
define_instruction(bumpcnt) {
extern size_t cxg_bumpcount;
extern int cxg_bumpcount;
ac = fixnum_obj((int)cxg_bumpcount);
gonexti();
}

16
i.h
View file

@ -396,14 +396,15 @@ declare_instruction(cigt, "Ci>", 0, "char-ci>?",
declare_instruction(cile, "Ci>!", 0, "char-ci<=?", 'c', AUTOGL)
declare_instruction(cige, "Ci<!", 0, "char-ci>=?", 'c', AUTOGL)
declare_instruction(strp, "S0", 0, "string?", '1', AUTOGL)
declare_instruction(str, "S1", 1, "string", '#', "%!0.0X3]1")
declare_instruction(str, "S1", 1, "string", '#', "S1(f)]0")
declare_instruction(smk, "S2\0'(c )", 0, "make-string", 'b', AUTOGL)
declare_instruction(slen, "S3", 0, "string-length", '1', AUTOGL)
declare_instruction(sget, "S4", 0, "string-ref", '2', AUTOGL)
declare_instruction(sput, "S5", 0, "string-set!", '3', AUTOGL)
declare_instruction(scat, "S6", 0, "string-cat", '2', AUTOGL)
declare_instruction(ssub, "S7", 0, "substring", '3', AUTOGL)
declare_instruction(spos, "S8", 0, "string-position", '2', AUTOGL)
declare_instruction(sapp, "Sa", 1, "string-append", '#', "Sa(f)]0")
declare_instruction(sapp2, "Sa2", 0, NULL, 0, NULL)
declare_instruction(supc, "Su", 0, "string-upcase", '1', AUTOGL)
declare_instruction(sdnc, "Sd", 0, "string-downcase", '1', AUTOGL)
declare_instruction(sflc, "Sf", 0, "string-foldcase", '1', AUTOGL)
@ -420,19 +421,21 @@ declare_instruction(sigt, "Si>", 0, "string-ci>?",
declare_instruction(sile, "Si>!", 0, "string-ci<=?", 'c', AUTOGL)
declare_instruction(sige, "Si<!", 0, "string-ci>=?", 'c', AUTOGL)
declare_instruction(vecp, "V0", 0, "vector?", '1', AUTOGL)
declare_instruction(vec, "V1", 1, "vector", '#', "%!0.0X1]1")
declare_instruction(vec, "V1", 1, "vector", '#', "V1(f)]0")
declare_instruction(vmk, "V2\0f", 0, "make-vector", 'b', AUTOGL)
declare_instruction(vlen, "V3", 0, "vector-length", '1', AUTOGL)
declare_instruction(vget, "V4", 0, "vector-ref", '2', AUTOGL)
declare_instruction(vput, "V5", 0, "vector-set!", '3', AUTOGL)
declare_instruction(vcat, "V6", 0, "vector-cat", '2', AUTOGL)
declare_instruction(vapp, "Va", 1, "vector-append", '#', "Va(f)]0")
declare_instruction(vapp2, "Va2", 0, NULL, 0, NULL)
declare_instruction(bvecp, "B0", 0, "bytevector?", '1', AUTOGL)
declare_instruction(bvec, "B1", 1, "bytevector", '#', "%!0.0E1]1")
declare_instruction(bvec, "B1", 1, "bytevector", '#', "B1(f)]0")
declare_instruction(bmk, "B2\0'0", 0, "make-bytevector", 'b', AUTOGL)
declare_instruction(blen, "B3", 0, "bytevector-length", '1', AUTOGL)
declare_instruction(bget, "B4", 0, "bytevector-u8-ref", '2', AUTOGL)
declare_instruction(bput, "B5", 0, "bytevector-u8-set!", '3', AUTOGL)
declare_instruction(bsub, "B7", 0, "subbytevector", '3', AUTOGL)
declare_instruction(bapp, "Ba", 1, "bytevector-append", '#', "Ba(f)]0")
declare_instruction(beq, "B=", 0, "bytevector=?", 'c', AUTOGL)
declare_instruction(recp, "O0\0Y9", 0, "record?", 'b', AUTOGL)
declare_instruction(rmk, "O2\0f", 0, "make-record", 't', AUTOGL)
@ -493,12 +496,15 @@ declare_instruction(pfc, "P78", 0, "port-fold-case?",
declare_instruction(spfc, "P79", 0, "set-port-fold-case!", '2', AUTOGL)
declare_instruction(gos, "P90", 0, "get-output-string", '1', AUTOGL)
declare_instruction(gob, "P91", 0, "get-output-bytevector", '1', AUTOGL)
declare_instruction(gov, "P92", 0, "%get-output-value", '2', AUTOGL)
declare_instruction(rdc, "R0\0Pi", 0, "read-char", 'u', AUTOGL)
declare_instruction(rdac, "R1\0Pi", 0, "peek-char", 'u', AUTOGL)
declare_instruction(rdcr, "R2\0Pi", 0, "char-ready?", 'u', AUTOGL)
declare_instruction(rd8, "R3\0Pi", 0, "read-u8", 'u', AUTOGL)
declare_instruction(rda8, "R4\0Pi", 0, "peek-u8", 'u', AUTOGL)
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)
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)

1
misc/Skint-prelude.scm
View file

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

525
n.c
View file

@ -478,7 +478,7 @@ static int noputch(int c, void *p) { return EOF; }
static int noflush(void *p) { return EOF; }
static int noctl(const char *cmd, void *p, ...) { return -1; }
static int noctl(ctlop_t op, void *p, ...) { return -1; }
static void ffree(void *vp) {
/* FILE *fp = vp; assert(fp); cannot fclose(fp) here because of FILE reuse! */ }
@ -499,6 +499,27 @@ static int sigetch(sifile_t *fp) {
static int siungetch(int c, sifile_t *fp) {
assert(fp && fp->p); --(fp->p); assert(c == *(fp->p)); return c; }
static int sictl(ctlop_t op, sifile_t *fp, ...)
{
if (op == CTLOP_RDLN) {
va_list args; int **pd;
va_start(args, fp);
pd = va_arg(args, int **);
if (*(fp->p) == 0) {
*pd = NULL;
} else {
char *s = strchr(fp->p, '\n');
if (s) { *pd = newstringn(fp->p, s-fp->p); fp->p = s+1; }
else { *pd = newstring(fp->p); fp->p += strlen(fp->p); }
}
va_end(args);
return 0;
}
return -1;
}
bvifile_t *bvialloc(unsigned char *p, unsigned char *e, void *base) {
bvifile_t *fp = cxm_cknull(malloc(sizeof(bvifile_t)), "malloc(bvifile)");
fp->p = p; fp->e = e; fp->base = base; return fp; }
@ -516,11 +537,14 @@ static int bvigetch(bvifile_t *fp) {
static int bviungetch(int c, bvifile_t *fp) {
assert(fp && fp->p && fp->e); --(fp->p); assert(c == *(fp->p)); return c; }
cbuf_t* cbinit(cbuf_t* pcb) {
pcb->fill = pcb->buf = cxm_cknull(malloc(64), "malloc(cbdata)");
pcb->end = pcb->buf + 64; return pcb;
}
cbuf_t* newcb(void) {
cbuf_t* pcb = cxm_cknull(malloc(sizeof(cbuf_t)), "malloc(cbuf)");
pcb->fill = pcb->buf = cxm_cknull(malloc(64), "malloc(cbdata)");
pcb->end = pcb->buf + 64; pcb->off = 0;
return pcb;
return cbinit(pcb);
}
void freecb(cbuf_t* pcb) { if (pcb) { free(pcb->buf); free(pcb); } }
@ -533,23 +557,18 @@ static void cbgrow(cbuf_t* pcb, size_t n) {
pcb->fill = pcb->buf + cnt, pcb->end = pcb->buf + newsz;
}
char* cballoc(cbuf_t* pcb, size_t n) {
assert(pcb); /* allow for extra 1 char after n */
if (pcb->fill + n+1 > pcb->end) cbgrow(pcb, n+1);
pcb->fill += n;
return pcb->fill - n;
}
int cbputc(int c, cbuf_t* pcb) {
if (pcb->fill == pcb->end) cbgrow(pcb, 1);
*(pcb->fill)++ = c; return c;
}
int cbgetc(cbuf_t* pcb) {
if (pcb->buf + pcb->off >= pcb->fill) return EOF;
return pcb->buf[pcb->off++];
}
int cbungetc(cbuf_t* pcb, int c) {
if (!pcb->off) return EOF;
pcb->off -= 1;
return c;
}
static int cbflush(cbuf_t* pcb) { return 0; }
static int cbclose(cbuf_t* pcb) { free(pcb->buf); pcb->buf = NULL; return 0; }
@ -560,65 +579,150 @@ char* cbdata(cbuf_t* pcb) {
if (pcb->fill == pcb->end) cbgrow(pcb, 1); *(pcb->fill) = 0; return pcb->buf;
}
cbuf_t *cbclear(cbuf_t *pcb) { pcb->fill = pcb->buf; return pcb; }
typedef enum { TIF_NONE = 0, TIF_EOF = 1, TIF_CI = 2 } tiflags_t;
typedef struct tifile_tag { cbuf_t cb; char *next; FILE *fp; int lno; tiflags_t flags; } tifile_t;
tifile_t *tialloc(FILE *fp) {
tifile_t *tp = cxm_cknull(malloc(sizeof(tifile_t)), "malloc(tifile)");
cbinit(&tp->cb); tp->next = tp->cb.buf; *(tp->next) = 0;
tp->fp = fp; tp->lno = 0; tp->flags = TIF_NONE;
return tp;
}
static void tifree(tifile_t *tp) {
assert(tp); cbclose(&tp->cb); ffree(tp->fp); free(tp); }
static int ticlose(tifile_t *tp) {
assert(tp); cbclose(&tp->cb); fclose(tp->fp); return 0; }
static int tigetch(tifile_t *tp) {
int c; retry: c = *(tp->next);
if (c != 0) { ++(tp->next); return c; }
/* see if we need to return actual 0 or refill the line */
if (tp->next < tp->cb.fill) { ++(tp->next); return c; }
else if (tp->flags & TIF_EOF || !tp->fp) return EOF;
else { /* refill with next line from fp */
cbuf_t *pcb = cbclear(&tp->cb); FILE *fp = tp->fp;
#if 1
char *line = fgets(cballoc(pcb, 256), 256, fp);
if (!line) { cbclear(pcb); tp->flags |= TIF_EOF; }
else { /* manually add the rest of the line */
size_t len = strlen(line); pcb->fill = pcb->buf + len;
if (len > 0 && line[len-1] != '\n') {
do { c = getc(fp); if (c == EOF) break; cbputc(c, pcb); } while (c != '\n');
if (c == EOF) tp->flags |= TIF_EOF;
}
}
#else
do { c = getc(fp); if (c == EOF) break; cbputc(c, pcb); } while (c != '\n');
if (c == EOF) tp->flags |= TIF_EOF;
#endif
tp->lno += 1; tp->next = cbdata(pcb); /* 0-term */
goto retry;
}
}
static int tiungetch(int c, tifile_t *tp) {
assert(tp->next > tp->cb.buf && tp->next <= tp->cb.fill);
tp->next -= 1; // todo: utf-8
return c;
}
static int tictl(ctlop_t op, tifile_t *tp, ...)
{
if (op == CTLOP_RDLN) {
va_list args; int c, n, **pd;
va_start(args, tp);
pd = va_arg(args, int **);
c = tigetch(tp);
if (c == EOF) {
*pd = NULL;
} else {
char *s; tiungetch(c, tp);
s = tp->next; n = tp->cb.fill - s;
if (n > 0 && s[n-1] == '\n') --n;
*pd = newstringn(s, n);
tp->next = tp->cb.fill;
}
va_end(args);
return 0;
}
return -1;
}
/* port type array */
#define PORTTYPES_MAX 8
static cxtype_port_t cxt_port_types[PORTTYPES_MAX] = {
cxtype_port_t cxt_port_types[PORTTYPES_MAX] = {
#define IPORT_CLOSED_PTINDEX 0
{ "closed-input-port", (void (*)(void*))nofree,
SPT_CLOSED, (int (*)(void*))noclose,
SPT_INPUT, (int (*)(void*))noclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
(int (*)(ctlop_t, void *, ...))noctl },
#define IPORT_FILE_PTINDEX 1
{ "file-input-port", ffree,
SPT_INPUT, (int (*)(void*))fclose,
{ "file-input-port", (void (*)(void*))tifree,
SPT_INPUT, (int (*)(void*))ticlose,
(int (*)(void*))tigetch, (int (*)(int, void*))tiungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(ctlop_t, void *, ...))tictl },
#define IPORT_BYTEFILE_PTINDEX 2
{ "binary-file-input-port", ffree,
SPT_INPUT|SPT_BINARY, (int (*)(void*))fclose,
(int (*)(void*))(fgetc), (int (*)(int, void*))(ungetc),
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
#define IPORT_STRING_PTINDEX 2
(int (*)(ctlop_t, void *, ...))noctl },
#define IPORT_STRING_PTINDEX 3
{ "string-input-port", (void (*)(void*))sifree,
SPT_INPUT, (int (*)(void*))siclose,
(int (*)(void*))sigetch, (int (*)(int, void*))siungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
#define IPORT_BYTEVECTOR_PTINDEX 3
(int (*)(ctlop_t, void *, ...))sictl },
#define IPORT_BYTEVECTOR_PTINDEX 4
{ "bytevector-input-port", (void (*)(void*))bvifree,
SPT_INPUT, (int (*)(void*))bviclose,
SPT_INPUT|SPT_BINARY, (int (*)(void*))bviclose,
(int (*)(void*))bvigetch, (int (*)(int, void*))bviungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
#define OPORT_CLOSED_PTINDEX 4
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_CLOSED_PTINDEX 5
{ "closed-output-port", (void (*)(void*))nofree,
SPT_OUTPUT, (int (*)(void*))noclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
#define OPORT_FILE_PTINDEX 5
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_FILE_PTINDEX 6
{ "file-output-port", ffree,
SPT_OUTPUT, (int (*)(void*))fclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))(fputc), (int (*)(void*))fflush,
(int (*)(const char *, void *, ...))noctl },
#define OPORT_STRING_PTINDEX 6
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_BYTEFILE_PTINDEX 7
{ "binary-file-output-port", ffree,
SPT_OUTPUT|SPT_BINARY, (int (*)(void*))fclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))(fputc), (int (*)(void*))fflush,
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_STRING_PTINDEX 8
{ "string-output-port", (void (*)(void*))freecb,
SPT_OUTPUT, (int (*)(void*))cbclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))cbputc, (int (*)(void*))cbflush,
(int (*)(const char *, void *, ...))noctl },
#define OPORT_BYTEVECTOR_PTINDEX 7
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_BYTEVECTOR_PTINDEX 9
{ "bytevector-output-port", (void (*)(void*))freecb,
SPT_OUTPUT, (int (*)(void*))cbclose,
SPT_OUTPUT|SPT_BINARY, (int (*)(void*))cbclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))cbputc, (int (*)(void*))cbflush,
(int (*)(const char *, void *, ...))noctl }
(int (*)(ctlop_t, void *, ...))noctl }
};
cxtype_t *IPORT_CLOSED_NTAG = (cxtype_t *)&cxt_port_types[IPORT_CLOSED_PTINDEX];
cxtype_t *IPORT_FILE_NTAG = (cxtype_t *)&cxt_port_types[IPORT_FILE_PTINDEX];
cxtype_t *IPORT_BYTEFILE_NTAG = (cxtype_t *)&cxt_port_types[IPORT_BYTEFILE_PTINDEX];
cxtype_t *IPORT_STRING_NTAG = (cxtype_t *)&cxt_port_types[IPORT_STRING_PTINDEX];
cxtype_t *IPORT_BYTEVECTOR_NTAG = (cxtype_t *)&cxt_port_types[IPORT_BYTEVECTOR_PTINDEX];
@ -627,6 +731,8 @@ cxtype_t *OPORT_CLOSED_NTAG = (cxtype_t *)&cxt_port_types[OPORT_CLOSED_PTINDEX];
cxtype_t *OPORT_FILE_NTAG = (cxtype_t *)&cxt_port_types[OPORT_FILE_PTINDEX];
cxtype_t *OPORT_BYTEFILE_NTAG = (cxtype_t *)&cxt_port_types[OPORT_BYTEFILE_PTINDEX];
cxtype_t *OPORT_STRING_NTAG = (cxtype_t *)&cxt_port_types[OPORT_STRING_PTINDEX];
cxtype_t *OPORT_BYTEVECTOR_NTAG = (cxtype_t *)&cxt_port_types[OPORT_BYTEVECTOR_PTINDEX];
@ -864,10 +970,29 @@ static void wrs(char *s, wenv_t *e) {
assert(vt); while (*s) vt->putch(*s++, pp);
}
static int cleansymname(char *s) {
#if 1
static char inisub_map[256] = { /* ini: [a-zA-Z!$%&*:/<=>?@^_~] sub: ini + [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, 2, 0, 2, 2, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 0, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 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, 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,
};
char *p = s; while (*p) if (inisub_map[*p++ & 0xFF] == 0) return 0; if (!s[0]) return 0;
if (inisub_map[s[0] & 0xFF] == 1) return 1;
#else
char *inits = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?@^_~";
char *subss = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?@^_~0123456789.@+-";
if (s[0] == 0 || s[strspn(s, subss)] != 0) return 0; else if (strchr(inits, s[0])) return 1;
else if (s[0] == '+' || s[0] == '-') return s[1] == 0 || (s[1] == '.' && s[2] && !isdigit(s[2])) || !isdigit(s[1]);
#endif
if (s[0] == '+' || s[0] == '-') {
if (strcmp_ci(s+1, "inf.0") == 0 || strcmp_ci(s+1, "nan.0") == 0) return 0;
if ((s[1] == 'i' || s[1] == 'I') && s[2] == 0) return 0;
return s[1] == 0 || (s[1] == '.' && s[2] && !isdigit(s[2])) || (s[1] != '.' && !isdigit(s[1]));
}
else return s[0] == '.' && s[1] && !isdigit(s[1]);
}
static void wrdatum(obj o, wenv_t *e) {
@ -1017,7 +1142,7 @@ void oportputshared(obj x, obj p, int disp) {
extern int is_tty_port(obj o)
{
FILE *fp = NULL;
if ((cxtype_t*)iportvt(o) == IPORT_FILE_NTAG) fp = (FILE*)iportdata(o);
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));
@ -1085,4 +1210,324 @@ 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.@+-] */
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,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 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, 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,
};
#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,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 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, 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] */
#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)
{
switch (c) {
case '\t': case '\r': case '\n': case ' ':
case '(': case ')': case '[': case ']':
case '|': case '\"': case ';': case EOF:
return 1;
}
return 0;
}
static int lex_1esc(int c)
{
switch (c) {
case 'a': return '\a';
case 'b': return '\b';
case 't': return '\t';
case 'n': return '\n';
case 'r': return '\r';
case '|': return '|';
case '\"': return '\"';
case '\\': return '\\';
}
return EOF;
}
static int lex_xesc(int c, int xc)
{
if (c >= '0' && c <= '9') return (xc << 4) + c - '0';
if (c >= 'A' && c <= 'F') return (xc << 4) + 10 + c - 'A';
if (c >= 'a' && c <= 'f') return (xc << 4) + 10 + c - 'a';
return EOF;
}
/* slex: splits input into tokens delivered via char buf */
int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *pcb)
{
int c, xc;
next: cbclear(pcb);
switch (c = in_getc(in)) {
case EOF: return TT_EOF;
case ',': goto after_comma;
case '`': return TT_QQUOTE;
case '\'': return TT_QUOTE;
case ']': return TT_CLOSE2;
case '[': return TT_OPENLIST2;
case ')': return TT_CLOSE;
case '(': return TT_OPENLIST;
case ';': goto in_linecomm;
case '|': goto in_barsym;
case '\"': goto in_string;
case '#': cbputc(c, pcb); goto after_hash;
case '.': cbputc(c, pcb); goto after_dot;
default:
if (is_numsym(c)) goto in_numsym;
if ((c >= '\t' && c <= '\n') || (c >= '\f' && c <= '\r') || c == ' ') goto in_whitespace;
in_ungetc(c, in); goto err;
}
in_whitespace:
c = in_getc(in);
if (c == EOF) return TT_EOF;
if ((c >= '\t' && c <= '\n') || (c >= '\f' && c <= '\r') || c == ' ') goto in_whitespace;
in_ungetc(c, in); goto next;
in_linecomm:
c = in_getc(in);
if (c == EOF) return TT_EOF;
if (c != '\n') goto in_linecomm;
goto next;
in_numsym:
while (is_numsym(c)) { cbputc(c, pcb); c = in_getc(in); }
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
if (cleansymname(cbdata(pcb))) return TT_SYMBOL;
return TT_NUMBER;
after_dot:
c = in_getc(in); if (is_numsym(c)) goto in_numsym;
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
return TT_DOT;
after_hash:
c = in_getc(in); if (c == EOF) goto err;
if (c == '(') return TT_OPENVEC;
if (c == '\\') { cbclear(pcb); goto in_char; }
if (c == '|') { // handcoded
int level = 1;
normal:
switch (in_getc(in)) {
case EOF: goto err;
case '#': goto after_hashc;
case '|': goto after_barc;
default: goto normal;
}
after_hashc:
switch (in_getc(in)) {
case EOF: goto err;
case '#': goto after_hashc;
case '|': level++;
default: goto normal;
}
after_barc:
switch (in_getc(in)) {
case EOF: goto err;
case '|': goto after_barc;
case '#': if (!--level) goto next;
default: goto normal;
}
}
if (c == '!') { cbclear(pcb); goto after_shebang; }
if (c == '&') return TT_BOX;
if (c == 'u' || c == 'U') { cbputc(tolower(c), cbclear(pcb)); goto after_hashu; }
if (c >= '0' && c <= '9') { cbputc(c, cbclear(pcb)); goto in_hashnum; }
if (c == 'B' || (c >= 'D' && c <= 'E') || c == 'I' || c == 'O' || c == 'X' ||
c == 'b' || (c >= 'd' && c <= 'e') || c == 'i' || c == 'o' || c == 'x')
{ cbputc(tolower(c), pcb); goto in_hashradixie; }
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z'))
{ cbputc(tolower(c), cbclear(pcb)); goto in_hashname; }
if (c == ';') { cbclear(pcb); return TT_HSEMI; } // todo: skip S-exp
in_ungetc(c, in); goto err;
after_comma:
c = in_getc(in);
if (c == EOF) return TT_UNQUOTE;
if (c == '@') return TT_UNQSPL;
in_ungetc(c, in); return TT_UNQUOTE;
in_char:
c = in_getc(in); if (c == EOF) goto eoferr;
if (c == 'x' || c == 'X') goto in_char_xesc;
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) goto in_char_name;
cbputc(c, pcb); // todo: parse utf-8
c = in_getc(in); if (c != EOF) in_ungetc(c, in);
if (!is_delimiter(c)) goto err;
return TT_CHAR;
in_char_name:
while ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(c, pcb); c = in_getc(in); }
if (cblen(pcb) > 1) {
char *s = cbdata(pcb); int x = EOF;
if (0 == strcmp(s, "null")) x = '\0';
else if (0 == strcmp(s, "alarm")) x = '\a';
else if (0 == strcmp(s, "backspace")) x = '\b';
else if (0 == strcmp(s, "delete")) x = '\x7F';
else if (0 == strcmp(s, "escape")) x = '\x1B';
else if (0 == strcmp(s, "newline")) x = '\n';
else if (0 == strcmp(s, "return")) x = '\r';
else if (0 == strcmp(s, "space")) x = ' ';
else if (0 == strcmp(s, "tab")) x = '\t';
else if (0 == strcmp(s, "vtab")) x = '\v'; //++
else if (0 == strcmp(s, "page")) x = '\f'; //++
else if (0 == strcmp(s, "linefeed")) x = '\n'; //++
if (x == EOF) goto err;
cbputc(x, cbclear(pcb));
}
if (c != EOF) in_ungetc(c, in);
if (!is_delimiter(c)) goto err;
return TT_CHAR;
in_char_xesc:
xc = c; c = in_getc(in);
if (is_delimiter(c)) { if (c != EOF) in_ungetc(c, in); cbputc(xc, pcb); return TT_CHAR; }
else xc = 0;
while (!is_delimiter(c) && (xc = lex_xesc(c, xc)) != EOF) c = in_getc(in);
if (!is_delimiter(c) || xc == EOF) goto err;
if (c != EOF) in_ungetc(c, in); cbputc(xc, pcb); return TT_CHAR; // todo: cbput8c
in_barsym:
c = in_getc(in); if (c == EOF) goto eoferr;
else if (c == '|') return TT_SYMBOL;
else if (c == '\\') goto in_barsym_esc;
cbputc(c, pcb); goto in_barsym; // todo: parse utf-8
in_barsym_esc:
c = in_getc(in); if (c == EOF) goto err;
if (c == 'x' || c == 'X') goto in_barsym_xesc;
xc = lex_1esc(c); if (xc == EOF) goto err;
cbputc(xc, pcb); goto in_barsym; // todo: cbput8c
in_barsym_xesc:
xc = 0; do c = in_getc(in);
while (c != ';' && (xc = lex_xesc(c, xc)) != EOF);
if (c != ';' || xc == EOF) goto err;
cbputc(xc, pcb); goto in_barsym; // todo: cbput8c
in_string:
c = in_getc(in); if (c == EOF) goto eoferr;
else if (c == '\"') return TT_STRING;
else if (c == '\\') goto in_str_esc;
cbputc(c, pcb); goto in_string; // todo: parse utf-8
in_str_esc:
c = in_getc(in); if (c == EOF) goto err;
if (c == 'x' || c == 'X') goto in_str_xesc;
if (c == '\t' || c == ' ' || c == '\r' || c == '\n') goto in_str_sesc;
xc = lex_1esc(c); if (xc == EOF) goto err;
cbputc(xc, pcb); goto in_string; // todo: cbput8c
in_str_sesc:
while (c == '\t' || c == ' ' || c == '\r') c = in_getc(in);
if (c != '\n') goto err;
do c = in_getc(in); while (c == '\t' || c == ' ');
if (c == EOF) goto err;
in_ungetc(c, in); goto in_string;
in_str_xesc:
xc = 0; do c = in_getc(in);
while (c != ';' && (xc = lex_xesc(c, xc)) != EOF);
if (c != ';' || xc == EOF) goto err;
cbputc(xc, pcb); goto in_string; // todo: cbput8c
in_hashradixie:
c = in_getc(in); if (c == EOF) goto err;
while (is_num(c)) { cbputc(tolower(c), pcb); c = in_getc(in); }
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
return TT_NUMBER;
in_hashname:
c = in_getc(in);
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(tolower(c), pcb); goto in_hashname; }
if (is_delimiter(c)) {
char *s = cbdata(pcb); if (c != EOF) in_ungetc(c, in);
if (0 == strcmp(s, "t")) return TT_TRUE;
else if (0 == strcmp(s, "true")) return TT_TRUE;
else if (0 == strcmp(s, "f")) return TT_FALSE;
else if (0 == strcmp(s, "false")) return TT_FALSE;
}
goto err;
in_hashnum:
c = in_getc(in); if (c == EOF) goto err;
if (c == '#') return TT_HREF;
if (c == '=') return TT_HDEF;
if (c >= '0' && c <= '9') { cbputc(c, pcb); goto in_hashnum; }
in_ungetc(c, in); goto err;
after_hashu:
c = in_getc(in);
if (c == '8') { cbclear(pcb); goto after_hashu8; }
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(tolower(c), pcb); goto in_hashname; }
in_ungetc(c, in); goto err;
after_hashu8:
c = in_getc(in); if (c == EOF) goto err;
if (c == '(') return TT_OPENU8VEC;
in_ungetc(c, in); goto err;
after_shebang:
c = in_getc(in); if (c == EOF) goto err;
if (c == ' ' || c == '\t') goto in_shebang_line;
else if (c == '-' || (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || c == '_' || (c >= 'a' && c <= 'z'))
{ cbputc(c, pcb); goto in_shebang_name; }
in_ungetc(c, in); goto err;
in_shebang_line:
while (c == ' ' || c == '\t') c = in_getc(in);
while (c != EOF && c != '\n') { cbputc(c, pcb); c = in_getc(in); }
while (pcb->fill > pcb->buf && (pcb->fill[-1] == ' ' || pcb->fill[-1] == '\t')) pcb->fill -= 1;
return TT_SHEBANG;
in_shebang_name:
c = in_getc(in);
if (c == EOF) goto in_shebang_pre;
else if (c == '-' || (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || c == '_' || (c >= 'a' && c <= 'z'))
{ cbputc(c, pcb); goto in_shebang_name; }
else { in_ungetc(c, in); goto in_shebang_pre; }
in_shebang_pre: {
char *s = cbdata(pcb);
if (strcmp_ci(s, "fold-case") == 0) return TT_SHEBANG_FC;
if (strcmp_ci(s, "no-fold-case") == 0) return TT_SHEBANG_NF;
return TT_SHEBANG;
}
err:
eoferr:
return TT_ERR;
}

30
n.h
View file

@ -400,28 +400,33 @@ extern obj* procedureref(obj o, int i);
#define mkshebang(i) mkimm(i, SHEBANG_ITAG)
#define getshebang(o) getimmu(o, SHEBANG_ITAG)
/* input/output ports */
typedef enum { CTLOP_RDLN } ctlop_t;
typedef struct { /* extends cxtype_t */
const char *tname;
void (*free)(void*);
enum { SPT_CLOSED = 0, SPT_INPUT = 1, SPT_OUTPUT = 2, SPT_IO = 3 } spt;
enum { SPT_INPUT = 1, SPT_OUTPUT = 2, SPT_IO = 3, SPT_BINARY = 4 } spt;
int (*close)(void*);
int (*getch)(void*);
int (*ungetch)(int, void*);
int (*putch)(int, void*);
int (*flush)(void*);
int (*ctl)(const char*, void*, ...);
int (*ctl)(ctlop_t, void*, ...);
} cxtype_port_t, cxtype_iport_t, cxtype_oport_t;
#define PORTTYPES_MAX 10
extern cxtype_port_t cxt_port_types[PORTTYPES_MAX];
/* input ports */
extern cxtype_t *IPORT_CLOSED_NTAG;
extern cxtype_t *IPORT_FILE_NTAG;
extern cxtype_t *IPORT_BYTEFILE_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; }
if (pt >= (cxtype_t*)&cxt_port_types[0] &&
pt < (cxtype_t*)&cxt_port_types[PORTTYPES_MAX] &&
(((cxtype_port_t*)pt)->spt & SPT_INPUT))
return (cxtype_iport_t*)pt; else return NULL; }
#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)))
@ -434,6 +439,8 @@ static int iportpeekc(obj o) {
assert(vt); c = vt->getch(pp); if (c != EOF) vt->ungetch(c, pp); return c;
}
/* file input ports */
typedef struct tifile_tag tifile_t;
extern tifile_t *tialloc(FILE *fp);
#define mkiport_file(l, fp) hpushptr(fp, IPORT_FILE_NTAG, l)
/* string input ports */
typedef struct { char *p; void *base; } sifile_t;
@ -446,14 +453,16 @@ extern bvifile_t *bvialloc(unsigned char *p, unsigned char *e, void *base);
/* output ports */
extern cxtype_t *OPORT_CLOSED_NTAG;
extern cxtype_t *OPORT_FILE_NTAG;
extern cxtype_t *OPORT_BYTEFILE_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; }
if (pt >= (cxtype_t*)&cxt_port_types[0] &&
pt < (cxtype_t*)&cxt_port_types[PORTTYPES_MAX] &&
(((cxtype_port_t*)pt)->spt & SPT_OUTPUT))
return (cxtype_oport_t*)pt; else return NULL; }
#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)))
@ -476,7 +485,7 @@ static void oportflush(obj o) {
/* file 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; size_t off; } cbuf_t;
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);
@ -484,6 +493,7 @@ extern int cbgetc(cbuf_t* pcb);
extern int cbungetc(cbuf_t* pcb, int c);
extern size_t cblen(cbuf_t* pcb);
extern char* cbdata(cbuf_t* pcb);
extern cbuf_t* cbclear(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)
@ -498,3 +508,5 @@ extern obj isassoc(obj x, obj l);
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 */
extern int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *pcb);

537
pre/n.sf
View file

@ -887,17 +887,20 @@ unsigned char* bytevectorref(obj o, int i) {
; i/o ports
(%definition "/* input/output ports */")
(%definition "typedef enum { CTLOP_RDLN } ctlop_t;")
(%definition "typedef struct { /* extends cxtype_t */
const char *tname;
void (*free)(void*);
enum { SPT_CLOSED = 0, SPT_INPUT = 1, SPT_OUTPUT = 2, SPT_IO = 3 } spt;
enum { SPT_INPUT = 1, SPT_OUTPUT = 2, SPT_IO = 3, SPT_BINARY = 4 } spt;
int (*close)(void*);
int (*getch)(void*);
int (*ungetch)(int, void*);
int (*putch)(int, void*);
int (*flush)(void*);
int (*ctl)(const char*, void*, ...);
int (*ctl)(ctlop_t, void*, ...);
} cxtype_port_t, cxtype_iport_t, cxtype_oport_t;")
(%definition "#define PORTTYPES_MAX 10")
(%definition "extern cxtype_port_t cxt_port_types[PORTTYPES_MAX];")
(%localdef "/* shared generic methods */")
(%localdef "static void nofree(void *p) {}")
(%localdef "static int noclose(void *p) { return 0; }")
@ -905,21 +908,23 @@ unsigned char* bytevectorref(obj o, int i) {
(%localdef "static int noungetch(int c) { return c; }")
(%localdef "static int noputch(int c, void *p) { return EOF; }")
(%localdef "static int noflush(void *p) { return EOF; }")
(%localdef "static int noctl(const char *cmd, void *p, ...) { return -1; }")
(%localdef "static int noctl(ctlop_t op, void *p, ...) { return -1; }")
; input ports
(%definition "/* input ports */")
(%definition "extern cxtype_t *IPORT_CLOSED_NTAG;")
(%definition "extern cxtype_t *IPORT_FILE_NTAG;")
(%definition "extern cxtype_t *IPORT_BYTEFILE_NTAG;")
(%definition "extern cxtype_t *IPORT_STRING_NTAG;")
(%definition "extern cxtype_t *IPORT_BYTEVECTOR_NTAG;")
(%definition "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; }")
if (pt >= (cxtype_t*)&cxt_port_types[0] &&
pt < (cxtype_t*)&cxt_port_types[PORTTYPES_MAX] &&
(((cxtype_port_t*)pt)->spt & SPT_INPUT))
return (cxtype_iport_t*)pt; else return NULL; }")
(%definition "#define ckiportvt(o) ((cxtype_iport_t*)cxm_cknull(iportvt(o), \"iportvt\"))")
(%definition "#define isiport(o) (iportvt(o) != NULL)")
(%definition "#define iportdata(o) ((void*)(*objptr_from_obj(o)))")
@ -936,6 +941,8 @@ unsigned char* bytevectorref(obj o, int i) {
; file input ports
(%definition "/* file input ports */")
(%definition "typedef struct tifile_tag tifile_t;")
(%definition "extern tifile_t *tialloc(FILE *fp);")
(%localdef "static void ffree(void *vp) {
/* FILE *fp = vp; assert(fp); cannot fclose(fp) here because of FILE reuse! */ }")
(%definition "#define mkiport_file(l, fp) hpushptr(fp, IPORT_FILE_NTAG, l)")
@ -956,6 +963,21 @@ unsigned char* bytevectorref(obj o, int i) {
int c; assert(fp && fp->p); if (!(c = *(fp->p))) return EOF; ++(fp->p); return c; }")
(%localdef "static int siungetch(int c, sifile_t *fp) {
assert(fp && fp->p); --(fp->p); assert(c == *(fp->p)); return c; }")
(%localdef "static int sictl(ctlop_t op, sifile_t *fp, ...) {
if (op == CTLOP_RDLN) {
va_list args; int **pd; va_start(args, fp);
pd = va_arg(args, int **);
if (*(fp->p) == 0) *pd = NULL;
else {
char *s = strchr(fp->p, '\n');
if (s) { *pd = newstringn(fp->p, s-fp->p); fp->p = s+1; }
else { *pd = newstring(fp->p); fp->p += strlen(fp->p); }
}
va_end(args);
return 0;
}
return -1;
}")
(%definition "#define mkiport_string(l, fp) hpushptr(fp, IPORT_STRING_NTAG, l)")
; bytevector input ports
@ -982,14 +1004,16 @@ unsigned char* bytevectorref(obj o, int i) {
(%definition "/* output ports */")
(%definition "extern cxtype_t *OPORT_CLOSED_NTAG;")
(%definition "extern cxtype_t *OPORT_FILE_NTAG;")
(%definition "extern cxtype_t *OPORT_BYTEFILE_NTAG;")
(%definition "extern cxtype_t *OPORT_STRING_NTAG;")
(%definition "extern cxtype_t *OPORT_BYTEVECTOR_NTAG;")
(%definition "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; }")
if (pt >= (cxtype_t*)&cxt_port_types[0] &&
pt < (cxtype_t*)&cxt_port_types[PORTTYPES_MAX] &&
(((cxtype_port_t*)pt)->spt & SPT_OUTPUT))
return (cxtype_oport_t*)pt; else return NULL; }")
(%definition "#define ckoportvt(o) ((cxtype_oport_t*)cxm_cknull(oportvt(o), \"oportvt\"))")
(%definition "#define isoport(o) (oportvt(o) != NULL)")
(%definition "#define oportdata(o) ((void*)(*objptr_from_obj(o)))")
@ -1018,11 +1042,14 @@ unsigned char* bytevectorref(obj o, int i) {
(%definition "/* string output ports */")
(%definition "typedef struct cbuf_tag { char *buf; char *fill; char *end; } cbuf_t;")
(%definition "extern cbuf_t* newcb(void);")
(%localdef "cbuf_t* newcb(void) {
cbuf_t* pcb = cxm_cknull(malloc(sizeof(cbuf_t)), \"malloc(cbuf)\");
(%definition "extern cbuf_t* newcb(void);")
(%localdef "cbuf_t* cbinit(cbuf_t* pcb) {
pcb->fill = pcb->buf = cxm_cknull(malloc(64), \"malloc(cbdata)\");
pcb->end = pcb->buf + 64; return pcb;
}")
(%localdef "cbuf_t* newcb(void) {
cbuf_t* pcb = cxm_cknull(malloc(sizeof(cbuf_t)), \"malloc(cbuf)\");
return cbinit(pcb);
}")
(%definition "extern void freecb(cbuf_t* pcb);")
(%localdef "void freecb(cbuf_t* pcb) { if (pcb) { free(pcb->buf); free(pcb); } }")
@ -1033,9 +1060,17 @@ unsigned char* bytevectorref(obj o, int i) {
pcb->buf = cxm_cknull(realloc(pcb->buf, newsz), \"realloc(cbdata)\");
pcb->fill = pcb->buf + cnt, pcb->end = pcb->buf + newsz;
}")
(%definition "extern char* cballoc(cbuf_t* pcb, size_t n);")
(%localdef "char* cballoc(cbuf_t* pcb, size_t n) {
assert(pcb); /* allow for extra 1 char after n */
if (pcb->fill + n+1 > pcb->end) cbgrow(pcb, n+1);
pcb->fill += n;
return pcb->fill - n;
}")
(%definition "extern int cbputc(int c, cbuf_t* pcb);")
(%localdef "int cbputc(int c, cbuf_t* pcb) {
if ((pcb)->fill == (pcb)->end) cbgrow(pcb, 1); *((pcb)->fill)++ = c; return c;
if (pcb->fill == pcb->end) cbgrow(pcb, 1);
*(pcb->fill)++ = c; return c;
}")
(%localdef "static int cbflush(cbuf_t* pcb) { return 0; }")
(%localdef "static int cbclose(cbuf_t* pcb) { free(pcb->buf); pcb->buf = NULL; return 0; }")
@ -1045,6 +1080,8 @@ unsigned char* bytevectorref(obj o, int i) {
(%localdef "char* cbdata(cbuf_t* pcb) {
if (pcb->fill == pcb->end) cbgrow(pcb, 1); *(pcb->fill) = 0; return pcb->buf;
}")
(%definition "extern cbuf_t* cbclear(cbuf_t* pcb);")
(%localdef "cbuf_t *cbclear(cbuf_t *pcb) { pcb->fill = pcb->buf; return pcb; }")
(%definition "#define mkoport_string(l, fp) hpushptr(fp, OPORT_STRING_NTAG, l)")
; bytevector output ports
@ -1052,66 +1089,150 @@ unsigned char* bytevectorref(obj o, int i) {
(%definition "/* bytevector output ports */")
(%definition "#define mkoport_bytevector(l, fp) hpushptr(fp, OPORT_BYTEVECTOR_NTAG, l)")
; text input port (uses cbuf)
(%localdef "buf_t *cbclear(cbuf_t *pcb) { pcb->fill = pcb->buf; return pcb; }
typedef enum { TIF_NONE = 0, TIF_EOF = 1, TIF_CI = 2 } tiflags_t;
struct tifile_tag { cbuf_t cb; char *next; FILE *fp; int lno; tiflags_t flags; };
tifile_t *tialloc(FILE *fp) {
tifile_t *tp = cxm_cknull(malloc(sizeof(tifile_t)), \"malloc(tifile)\");
cbinit(&tp->cb); tp->next = tp->cb.buf; *(tp->next) = 0;
tp->fp = fp; tp->lno = 0; tp->flags = TIF_NONE;
return tp;
}
static void tifree(tifile_t *tp) {
assert(tp); cbclose(&tp->cb); ffree(tp->fp); free(tp); }
static int ticlose(tifile_t *tp) {
assert(tp); cbclose(&tp->cb); fclose(tp->fp); return 0; }
static int tigetch(tifile_t *tp) {
int c; retry: c = *(tp->next);
if (c != 0) { ++(tp->next); return c; }
/* see if we need to return actual 0 or refill the line */
if (tp->next < tp->cb.fill) { ++(tp->next); return c; }
else if (tp->flags & TIF_EOF || !tp->fp) return EOF;
else { /* refill with next line from fp */
cbuf_t *pcb = cbclear(&tp->cb); FILE *fp = tp->fp;
char *line = fgets(cballoc(pcb, 256), 256, fp);
if (!line) { cbclear(pcb); tp->flags |= TIF_EOF; }
else { /* manually add the rest of the line */
size_t len = strlen(line); pcb->fill = pcb->buf + len;
if (len > 0 && line[len-1] != '\n') {
do { c = getc(fp); if (c == EOF) break; cbputc(c, pcb); } while (c != '\n');
if (c == EOF) tp->flags |= TIF_EOF;
}
}
tp->lno += 1; tp->next = cbdata(pcb); /* 0-term */
goto retry;
}
}
static int tiungetch(int c, tifile_t *tp) {
assert(tp->next > tp->cb.buf && tp->next <= tp->cb.fill);
tp->next -= 1; // todo: utf-8
return c;
}
static int tictl(ctlop_t op, tifile_t *tp, ...) {
if (op == CTLOP_RDLN) {
va_list args; int c, n, **pd;
va_start(args, tp);
pd = va_arg(args, int **);
c = tigetch(tp);
if (c == EOF) {
*pd = NULL;
} else {
char *s; tiungetch(c, tp);
s = tp->next; n = tp->cb.fill - s;
if (n > 0 && s[n-1] == '\n') --n;
*pd = newstringn(s, n);
tp->next = tp->cb.fill;
}
va_end(args);
return 0;
}
return -1;
}")
; port data, predicates and standard opening/closing convenience ops
(%localdef "/* port type array */")
(%localdef "#define PORTTYPES_MAX 8")
(%localdef "static cxtype_port_t cxt_port_types[PORTTYPES_MAX] = {
(%localdef "cxtype_port_t cxt_port_types[PORTTYPES_MAX] = {
#define IPORT_CLOSED_PTINDEX 0
{ \"closed-input-port\", (void (*)(void*))nofree,
SPT_CLOSED, (int (*)(void*))noclose,
SPT_INPUT, (int (*)(void*))noclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
(int (*)(ctlop_t, void *, ...))noctl },
#define IPORT_FILE_PTINDEX 1
{ \"file-input-port\", ffree,
SPT_INPUT, (int (*)(void*))fclose,
{ \"file-input-port\", (void (*)(void*))tifree,
SPT_INPUT, (int (*)(void*))ticlose,
(int (*)(void*))tigetch, (int (*)(int, void*))tiungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(ctlop_t, void *, ...))tictl },
#define IPORT_BYTEFILE_PTINDEX 2
{ \"binary-file-input-port\", ffree,
SPT_INPUT|SPT_BINARY, (int (*)(void*))fclose,
(int (*)(void*))(fgetc), (int (*)(int, void*))(ungetc),
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
#define IPORT_STRING_PTINDEX 2
(int (*)(ctlop_t, void *, ...))noctl },
#define IPORT_STRING_PTINDEX 3
{ \"string-input-port\", (void (*)(void*))sifree,
SPT_INPUT, (int (*)(void*))siclose,
(int (*)(void*))sigetch, (int (*)(int, void*))siungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
#define IPORT_BYTEVECTOR_PTINDEX 3
(int (*)(ctlop_t, void *, ...))sictl },
#define IPORT_BYTEVECTOR_PTINDEX 4
{ \"bytevector-input-port\", (void (*)(void*))bvifree,
SPT_INPUT, (int (*)(void*))bviclose,
SPT_INPUT|SPT_BINARY, (int (*)(void*))bviclose,
(int (*)(void*))bvigetch, (int (*)(int, void*))bviungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
#define OPORT_CLOSED_PTINDEX 4
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_CLOSED_PTINDEX 5
{ \"closed-output-port\", (void (*)(void*))nofree,
SPT_OUTPUT, (int (*)(void*))noclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(const char *, void *, ...))noctl },
#define OPORT_FILE_PTINDEX 5
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_FILE_PTINDEX 6
{ \"file-output-port\", ffree,
SPT_OUTPUT, (int (*)(void*))fclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))(fputc), (int (*)(void*))fflush,
(int (*)(const char *, void *, ...))noctl },
#define OPORT_STRING_PTINDEX 6
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_BYTEFILE_PTINDEX 7
{ \"binary-file-output-port\", ffree,
SPT_OUTPUT|SPT_BINARY, (int (*)(void*))fclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))(fputc), (int (*)(void*))fflush,
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_STRING_PTINDEX 8
{ \"string-output-port\", (void (*)(void*))freecb,
SPT_OUTPUT, (int (*)(void*))cbclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))cbputc, (int (*)(void*))cbflush,
(int (*)(const char *, void *, ...))noctl },
#define OPORT_BYTEVECTOR_PTINDEX 7
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_BYTEVECTOR_PTINDEX 9
{ \"bytevector-output-port\", (void (*)(void*))freecb,
SPT_OUTPUT, (int (*)(void*))cbclose,
SPT_OUTPUT|SPT_BINARY, (int (*)(void*))cbclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))cbputc, (int (*)(void*))cbflush,
(int (*)(const char *, void *, ...))noctl }
(int (*)(ctlop_t, void *, ...))noctl }
};")
(%localdef "cxtype_t *IPORT_CLOSED_NTAG = (cxtype_t *)&cxt_port_types[IPORT_CLOSED_PTINDEX];")
(%localdef "cxtype_t *IPORT_FILE_NTAG = (cxtype_t *)&cxt_port_types[IPORT_FILE_PTINDEX];")
(%localdef "cxtype_t *IPORT_BYTEFILE_NTAG = (cxtype_t *)&cxt_port_types[IPORT_BYTEFILE_PTINDEX];")
(%localdef "cxtype_t *IPORT_STRING_NTAG = (cxtype_t *)&cxt_port_types[IPORT_STRING_PTINDEX];")
(%localdef "cxtype_t *IPORT_BYTEVECTOR_NTAG = (cxtype_t *)&cxt_port_types[IPORT_BYTEVECTOR_PTINDEX];")
(%localdef "cxtype_t *OPORT_CLOSED_NTAG = (cxtype_t *)&cxt_port_types[OPORT_CLOSED_PTINDEX];")
(%localdef "cxtype_t *OPORT_FILE_NTAG = (cxtype_t *)&cxt_port_types[OPORT_FILE_PTINDEX];")
(%localdef "cxtype_t *OPORT_BYTEFILE_NTAG = (cxtype_t *)&cxt_port_types[OPORT_BYTEFILE_PTINDEX];")
(%localdef "cxtype_t *OPORT_STRING_NTAG = (cxtype_t *)&cxt_port_types[OPORT_STRING_PTINDEX];")
(%localdef "cxtype_t *OPORT_BYTEVECTOR_NTAG = (cxtype_t *)&cxt_port_types[OPORT_BYTEVECTOR_PTINDEX];")
@ -1365,10 +1486,23 @@ static void wrs(char *s, wenv_t *e) {
assert(vt); while (*s) vt->putch(*s++, pp);
}
static int cleansymname(char *s) {
char *inits = \"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?@^_~\";
char *subss = \"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?@^_~0123456789.@+-\";
if (s[0] == 0 || s[strspn(s, subss)] != 0) return 0; else if (strchr(inits, s[0])) return 1;
else if (s[0] == '+' || s[0] == '-') return s[1] == 0 || (s[1] == '.' && s[2] && !isdigit(s[2])) || !isdigit(s[1]);
static char inisub_map[256] = { /* ini: [a-zA-Z!$%&*:/<=>?@^_~] sub: ini + [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, 2, 0, 2, 2, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 0, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 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, 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,
};
char *p = s; while (*p) if (inisub_map[*p++ & 0xFF] == 0) return 0; if (!s[0]) return 0;
if (inisub_map[s[0] & 0xFF] == 1) return 1;
if (s[0] == '+' || s[0] == '-') {
if (strcmp_ci(s+1, \"inf.0\") == 0 || strcmp_ci(s+1, \"nan.0\") == 0) return 0;
if ((s[1] == 'i' || s[1] == 'I') && s[2] == 0) return 0;
return s[1] == 0 || (s[1] == '.' && s[2] && !isdigit(s[2])) || (s[1] != '.' && !isdigit(s[1]));
}
else return s[0] == '.' && s[1] && !isdigit(s[1]);
}
static void wrdatum(obj o, wenv_t *e) {
@ -1498,6 +1632,8 @@ static void wrdatum(obj o, wenv_t *e) {
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);")
(%definition "/* S-expression tokenizer */
extern int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *pcb);")
(%localdef "/* S-expression writers */
void oportputsimple(obj x, obj p, int disp) {
@ -1531,7 +1667,7 @@ void oportputshared(obj x, obj p, int disp) {
extern int is_tty_port(obj o)
{
FILE *fp = NULL;
if ((cxtype_t*)iportvt(o) == IPORT_FILE_NTAG) fp = (FILE*)iportdata(o);
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));
@ -1539,8 +1675,10 @@ extern int is_tty_port(obj o)
#ifdef WIN32
int dirsep = '\\\\';
int pathsep = ';';
#else
int dirsep = '/';
int pathsep = ':';
#endif
#ifdef LIBPATH
@ -1596,4 +1734,325 @@ 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.@+-] */
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,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 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, 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,
};
#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,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 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, 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] */
#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)
{
switch (c) {
case '\\t': case '\\r': case '\\n': case ' ':
case '(': case ')': case '[': case ']':
case '|': case '\\\"': case ';': case EOF:
return 1;
}
return 0;
}
static int lex_1esc(int c)
{
switch (c) {
case 'a': return '\\a';
case 'b': return '\\b';
case 't': return '\\t';
case 'n': return '\\n';
case 'r': return '\\r';
case '|': return '|';
case '\\\"': return '\\\"';
case '\\\\': return '\\\\';
}
return EOF;
}
static int lex_xesc(int c, int xc)
{
if (c >= '0' && c <= '9') return (xc << 4) + c - '0';
if (c >= 'A' && c <= 'F') return (xc << 4) + 10 + c - 'A';
if (c >= 'a' && c <= 'f') return (xc << 4) + 10 + c - 'a';
return EOF;
}
/* slex: splits input into tokens delivered via char buf */
int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *pcb)
{
int c, xc;
next: cbclear(pcb);
switch (c = in_getc(in)) {
case EOF: return TT_EOF;
case ',': goto after_comma;
case '`': return TT_QQUOTE;
case '\\'': return TT_QUOTE;
case ']': return TT_CLOSE2;
case '[': return TT_OPENLIST2;
case ')': return TT_CLOSE;
case '(': return TT_OPENLIST;
case ';': goto in_linecomm;
case '|': goto in_barsym;
case '\\\"': goto in_string;
case '#': cbputc(c, pcb); goto after_hash;
case '.': cbputc(c, pcb); goto after_dot;
default:
if (is_numsym(c)) goto in_numsym;
if ((c >= '\\t' && c <= '\\n') || (c >= '\\f' && c <= '\\r') || c == ' ') goto in_whitespace;
in_ungetc(c, in); goto err;
}
in_whitespace:
c = in_getc(in);
if (c == EOF) return TT_EOF;
if ((c >= '\\t' && c <= '\\n') || (c >= '\\f' && c <= '\\r') || c == ' ') goto in_whitespace;
in_ungetc(c, in); goto next;
in_linecomm:
c = in_getc(in);
if (c == EOF) return TT_EOF;
if (c != '\\n') goto in_linecomm;
goto next;
in_numsym:
while (is_numsym(c)) { cbputc(c, pcb); c = in_getc(in); }
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
if (cleansymname(cbdata(pcb))) return TT_SYMBOL;
return TT_NUMBER;
after_dot:
c = in_getc(in); if (is_numsym(c)) goto in_numsym;
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
return TT_DOT;
after_hash:
c = in_getc(in); if (c == EOF) goto err;
if (c == '(') return TT_OPENVEC;
if (c == '\\\\') { cbclear(pcb); goto in_char; }
if (c == '|') { // handcoded
int level = 1;
normal:
switch (in_getc(in)) {
case EOF: goto err;
case '#': goto after_hashc;
case '|': goto after_barc;
default: goto normal;
}
after_hashc:
switch (in_getc(in)) {
case EOF: goto err;
case '#': goto after_hashc;
case '|': level++;
default: goto normal;
}
after_barc:
switch (in_getc(in)) {
case EOF: goto err;
case '|': goto after_barc;
case '#': if (!--level) goto next;
default: goto normal;
}
}
if (c == '!') { cbclear(pcb); goto after_shebang; }
if (c == '&') return TT_BOX;
if (c == 'u' || c == 'U') { cbputc(tolower(c), cbclear(pcb)); goto after_hashu; }
if (c >= '0' && c <= '9') { cbputc(c, cbclear(pcb)); goto in_hashnum; }
if (c == 'B' || (c >= 'D' && c <= 'E') || c == 'I' || c == 'O' || c == 'X' ||
c == 'b' || (c >= 'd' && c <= 'e') || c == 'i' || c == 'o' || c == 'x')
{ cbputc(tolower(c), pcb); goto in_hashradixie; }
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z'))
{ cbputc(tolower(c), cbclear(pcb)); goto in_hashname; }
if (c == ';') { cbclear(pcb); return TT_HSEMI; } // todo: skip S-exp
in_ungetc(c, in); goto err;
after_comma:
c = in_getc(in);
if (c == EOF) return TT_UNQUOTE;
if (c == '@') return TT_UNQSPL;
in_ungetc(c, in); return TT_UNQUOTE;
in_char:
c = in_getc(in); if (c == EOF) goto eoferr;
if (c == 'x' || c == 'X') goto in_char_xesc;
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) goto in_char_name;
cbputc(c, pcb); // todo: parse utf-8
c = in_getc(in); if (c != EOF) in_ungetc(c, in);
if (!is_delimiter(c)) goto err;
return TT_CHAR;
in_char_name:
while ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(c, pcb); c = in_getc(in); }
if (cblen(pcb) > 1) {
char *s = cbdata(pcb); int x = EOF;
if (0 == strcmp(s, \"null\")) x = '\\0';
else if (0 == strcmp(s, \"alarm\")) x = '\\a';
else if (0 == strcmp(s, \"backspace\")) x = '\\b';
else if (0 == strcmp(s, \"delete\")) x = '\\x7F';
else if (0 == strcmp(s, \"escape\")) x = '\\x1B';
else if (0 == strcmp(s, \"newline\")) x = '\\n';
else if (0 == strcmp(s, \"return\")) x = '\\r';
else if (0 == strcmp(s, \"space\")) x = ' ';
else if (0 == strcmp(s, \"tab\")) x = '\\t';
else if (0 == strcmp(s, \"vtab\")) x = '\\v'; //++
else if (0 == strcmp(s, \"page\")) x = '\\f'; //++
else if (0 == strcmp(s, \"linefeed\")) x = '\\n'; //++
if (x == EOF) goto err;
cbputc(x, cbclear(pcb));
}
if (c != EOF) in_ungetc(c, in);
if (!is_delimiter(c)) goto err;
return TT_CHAR;
in_char_xesc:
xc = c; c = in_getc(in);
if (is_delimiter(c)) { if (c != EOF) in_ungetc(c, in); cbputc(xc, pcb); return TT_CHAR; }
else xc = 0;
while (!is_delimiter(c) && (xc = lex_xesc(c, xc)) != EOF) c = in_getc(in);
if (!is_delimiter(c) || xc == EOF) goto err;
if (c != EOF) in_ungetc(c, in); cbputc(xc, pcb); return TT_CHAR; // todo: cbput8c
in_barsym:
c = in_getc(in); if (c == EOF) goto eoferr;
else if (c == '|') return TT_SYMBOL;
else if (c == '\\\\') goto in_barsym_esc;
cbputc(c, pcb); goto in_barsym; // todo: parse utf-8
in_barsym_esc:
c = in_getc(in); if (c == EOF) goto err;
if (c == 'x' || c == 'X') goto in_barsym_xesc;
xc = lex_1esc(c); if (xc == EOF) goto err;
cbputc(xc, pcb); goto in_barsym; // todo: cbput8c
in_barsym_xesc:
xc = 0; do c = in_getc(in);
while (c != ';' && (xc = lex_xesc(c, xc)) != EOF);
if (c != ';' || xc == EOF) goto err;
cbputc(xc, pcb); goto in_barsym; // todo: cbput8c
in_string:
c = in_getc(in); if (c == EOF) goto eoferr;
else if (c == '\\\"') return TT_STRING;
else if (c == '\\\\') goto in_str_esc;
cbputc(c, pcb); goto in_string; // todo: parse utf-8
in_str_esc:
c = in_getc(in); if (c == EOF) goto err;
if (c == 'x' || c == 'X') goto in_str_xesc;
if (c == '\\t' || c == ' ' || c == '\\r' || c == '\\n') goto in_str_sesc;
xc = lex_1esc(c); if (xc == EOF) goto err;
cbputc(xc, pcb); goto in_string; // todo: cbput8c
in_str_sesc:
while (c == '\\t' || c == ' ' || c == '\\r') c = in_getc(in);
if (c != '\\n') goto err;
do c = in_getc(in); while (c == '\\t' || c == ' ');
if (c == EOF) goto err;
in_ungetc(c, in); goto in_string;
in_str_xesc:
xc = 0; do c = in_getc(in);
while (c != ';' && (xc = lex_xesc(c, xc)) != EOF);
if (c != ';' || xc == EOF) goto err;
cbputc(xc, pcb); goto in_string; // todo: cbput8c
in_hashradixie:
c = in_getc(in); if (c == EOF) goto err;
while (is_num(c)) { cbputc(tolower(c), pcb); c = in_getc(in); }
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
return TT_NUMBER;
in_hashname:
c = in_getc(in);
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(tolower(c), pcb); goto in_hashname; }
if (is_delimiter(c)) {
char *s = cbdata(pcb); if (c != EOF) in_ungetc(c, in);
if (0 == strcmp(s, \"t\")) return TT_TRUE;
else if (0 == strcmp(s, \"true\")) return TT_TRUE;
else if (0 == strcmp(s, \"f\")) return TT_FALSE;
else if (0 == strcmp(s, \"false\")) return TT_FALSE;
}
goto err;
in_hashnum:
c = in_getc(in); if (c == EOF) goto err;
if (c == '#') return TT_HREF;
if (c == '=') return TT_HDEF;
if (c >= '0' && c <= '9') { cbputc(c, pcb); goto in_hashnum; }
in_ungetc(c, in); goto err;
after_hashu:
c = in_getc(in);
if (c == '8') { cbclear(pcb); goto after_hashu8; }
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(tolower(c), pcb); goto in_hashname; }
in_ungetc(c, in); goto err;
after_hashu8:
c = in_getc(in); if (c == EOF) goto err;
if (c == '(') return TT_OPENU8VEC;
in_ungetc(c, in); goto err;
after_shebang:
c = in_getc(in); if (c == EOF) goto err;
if (c == ' ' || c == '\\t') goto in_shebang_line;
else if (c == '-' || (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || c == '_' || (c >= 'a' && c <= 'z'))
{ cbputc(c, pcb); goto in_shebang_name; }
in_ungetc(c, in); goto err;
in_shebang_line:
while (c == ' ' || c == '\\t') c = in_getc(in);
while (c != EOF && c != '\\n') { cbputc(c, pcb); c = in_getc(in); }
while (pcb->fill > pcb->buf && (pcb->fill[-1] == ' ' || pcb->fill[-1] == '\\t')) pcb->fill -= 1;
return TT_SHEBANG;
in_shebang_name:
c = in_getc(in);
if (c == EOF) goto in_shebang_pre;
else if (c == '-' || (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || c == '_' || (c >= 'a' && c <= 'z'))
{ cbputc(c, pcb); goto in_shebang_name; }
else { in_ungetc(c, in); goto in_shebang_pre; }
in_shebang_pre: {
char *s = cbdata(pcb);
if (strcmp_ci(s, \"fold-case\") == 0) return TT_SHEBANG_FC;
if (strcmp_ci(s, \"no-fold-case\") == 0) return TT_SHEBANG_NF;
return TT_SHEBANG;
}
err:
eoferr:
return TT_ERR;
}
")

548
pre/s.scm
View file

@ -274,8 +274,8 @@
; check that now relies on block tag being a non-immediate object, so we'll better put
; some pseudo-unique immediate object here -- and we don't have to be fast doing that
(let loop ([fl (cons name fields)] [sl '("rtd://")])
; NB: can't do (apply string-append ..) -- they are defined w/cover syntax below!
(cond [(null? fl) (string->symbol (apply-to-list %string-append (reverse sl)))]
; NB: can't do (apply string-append ..) -- apply is defined w/cover syntax below!
(cond [(null? fl) (string->symbol (apply-to-list string-append (reverse sl)))]
[(null? (cdr fl)) (loop (cdr fl) (cons (symbol->string (car fl)) sl))]
[else (loop (cdr fl) (cons ":" (cons (symbol->string (car fl)) sl)))])))
@ -743,7 +743,7 @@
(string->symbol (string-foldcase s)))
(define (symbol-append . syms) ; +
(string->symbol (apply-to-list %string-append (%map1 symbol->string syms))))
(string->symbol (apply-to-list string-append (%map1 symbol->string syms))))
;---------------------------------------------------------------------------------------------
@ -792,7 +792,7 @@
; (string-set! x i v)
; (list->string l)
; (%string->list1 s) +
; (string-cat s1 s2) +
; (string-append s ...)
; (substring s from to)
; (string-position s c) +
; (string-cmp s1 s2) +
@ -873,29 +873,6 @@
[(str start) (substring->vector str start (string-length str))]
[(str start end) (substring->vector str start end)]))
(define (strings-sum-length strs)
(let loop ([strs strs] [l 0])
(if (null? strs) l (loop (cdr strs) (fx+ l (string-length (car strs)))))))
(define (strings-copy-into! to strs)
(let loop ([strs strs] [i 0])
(if (null? strs)
to
(let ([str (car strs)] [strs (cdr strs)])
(let ([len (string-length str)])
(substring-copy! to i str 0 len)
(loop strs (fx+ i len)))))))
(define (%string-append . strs)
(strings-copy-into! (make-string (strings-sum-length strs)) strs))
(define-syntax string-append
(syntax-rules ()
[(_) ""] [(_ x) (%cks x)]
[(_ x y) (string-cat x y)]
[(_ . r) (%string-append . r)]
[_ %string-append]))
(define (string-trim-whitespace s) ; +
(let floop ([from 0] [len (string-length s)])
(if (and (< from len) (char-whitespace? (string-ref s from)))
@ -922,7 +899,7 @@
; (vector-set! v i x)
; (%vector->list1 v) +
; (list->vector l)
; (vector-cat v1 v2) +
; (vector-append v ...)
(define (subvector->list vec start end)
(let loop ([i (fx- end 1)] [l '()])
@ -991,29 +968,6 @@
[(vec start) (subvector->string vec start (vector-length vec))]
[(vec start end) (subvector->string vec start end)]))
(define (vectors-sum-length vecs)
(let loop ([vecs vecs] [l 0])
(if (null? vecs) l (loop (cdr vecs) (fx+ l (vector-length (car vecs)))))))
(define (vectors-copy-into! to vecs)
(let loop ([vecs vecs] [i 0])
(if (null? vecs)
to
(let ([vec (car vecs)] [vecs (cdr vecs)])
(let ([len (vector-length vec)])
(subvector-copy! to i vec 0 len)
(loop vecs (fx+ i len)))))))
(define (%vector-append . vecs)
(vectors-copy-into! (make-vector (vectors-sum-length vecs)) vecs))
(define-syntax vector-append
(syntax-rules ()
[(_) '#()] [(_ x) (%ckv x)]
[(_ x y) (vector-cat x y)]
[(_ . r) (%vector-append . r)]
[_ %vector-append]))
;---------------------------------------------------------------------------------------------
; Bytevectors
@ -1027,6 +981,7 @@
; (bytevector-length b)
; (bytevector-u8-ref b i)
; (bytevector-u8-set! b i u8)
; (bytevector-append b ...)
; (list->bytevector l) +
; (subbytevector b from to) +
; (bytevector=? b1 b2 b ...)
@ -1072,21 +1027,6 @@
[(bvec b start) (subbytevector-fill! bvec b start (bytevector-length bvec))]
[(bvec b start end) (subbytevector-fill! bvec b start end)]))
(define (%bytevectors-sum-length bvecs)
(let loop ([bvecs bvecs] [l 0])
(if (null? bvecs) l (loop (cdr bvecs) (fx+ l (bytevector-length (car bvecs)))))))
(define (%bytevectors-copy-into! to bvecs)
(let loop ([bvecs bvecs] [i 0])
(if (null? bvecs) to
(let ([bvec (car bvecs)] [bvecs (cdr bvecs)])
(let ([len (bytevector-length bvec)])
(subbytevector-copy! to i bvec 0 len)
(loop bvecs (fx+ i len)))))))
(define (bytevector-append . bvecs)
(%bytevectors-copy-into! (make-bytevector (%bytevectors-sum-length bvecs)) bvecs))
(define (subutf8->string vec start end)
(let ([p (open-output-string)])
(write-subbytevector vec start end p)
@ -1526,23 +1466,10 @@
; (read-u8 (p (current-input-port)))
; (peek-u8 (p (current-input-port)))
; (u8-ready? (p (current-input-port)))
; (read-line (p (current-input-port)))
; (eof-object? x)
; (eof-object)
(define (read-line . ?p)
(let ([p (if (null? ?p) (current-input-port) (car ?p))]
[op (open-output-string)])
(let loop ([read-nothing? #t])
(let ([c (read-char p)])
(cond [(or (eof-object? c) (char=? c #\newline))
(if (and (eof-object? c) read-nothing?)
c
(let ([s (get-output-string op)])
(close-output-port op)
s))]
[(char=? c #\return) (loop #f)]
[else (write-char c op) (loop #f)])))))
(define (read-substring! str start end p)
(let loop ([i start])
(if (fx>=? i end) (fx- i start)
@ -1593,352 +1520,121 @@
[(k) (read-subbytevector k (current-input-port))]
[(k p) (read-subbytevector k p)]))
(define (%read port simple? ci?)
(define-syntax r-error
(syntax-rules () [(_ p msg a ...) (read-error msg a ... 'port: p)]))
(define fold-case? (or ci? (port-fold-case? port)))
(define shared '())
(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 (patch-shared! form)
(cond [(pair? form)
(if (procedure? (car form))
(set-car! form (patch-ref! (car form)))
(patch-shared! (car form)))
(if (procedure? (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)
(vector-set! form i (patch-ref! fi))
(patch-shared! fi)))
(loop (fx+ i 1))))]
[(box? form)
(if (procedure? (unbox form))
(set-box! form (patch-shared! (unbox form)))
(patch-shared! (unbox form)))]))
(define (patch-shared form) (patch-shared! form) form)
(define reader-token-marker #f)
(define close-paren #f)
(define close-bracket #f)
(define dot #f)
(define () ; idless
(let ([rtm (list 'reader-token)])
(set! reader-token-marker rtm)
(set! close-paren (cons rtm "right parenthesis"))
(set! close-bracket (cons rtm "right bracket"))
(set! dot (cons rtm "\" . \""))))
(define (reader-token? form)
(and (pair? form) (eq? (car form) reader-token-marker)))
(define (char-symbolic? c)
(string-position c
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!$%&*/:<=>?^_~0123456789+-.@"))
(define (char-hex-digit? c)
(let ([scalar-value (char->integer c)])
(or (and (>= scalar-value 48) (<= scalar-value 57))
(and (>= scalar-value 65) (<= scalar-value 70))
(and (>= scalar-value 97) (<= scalar-value 102)))))
(define (char-delimiter? c)
(or (char-whitespace? c)
(char=? c #\)) (char=? c #\()
(char=? c #\]) (char=? c #\[)
(char=? c #\") (char=? c #\;)))
(define (sub-read-carefully p)
(let ([form (sub-read p)])
(cond [(eof-object? form)
(r-error p "unexpected end of file")]
[(reader-token? form)
(r-error p "unexpected token:" (cdr form))]
[else form])))
(define (sub-read-shebang p)
(if (eqv? (peek-char p) #\space)
(string->symbol (string-trim-whitespace (read-line p)))
(sub-read-carefully p)))
(define (sub-read p)
(let ([c (read-char p)])
(cond [(eof-object? c) c]
[(char-whitespace? c) (sub-read p)]
[(char=? c #\() (sub-read-list c p close-paren #t)]
[(char=? c #\)) close-paren]
[(char=? c #\[) (sub-read-list c p close-bracket #t)]
[(char=? c #\]) close-bracket]
[(char=? c #\') (list 'quote (sub-read-carefully p))]
[(char=? c #\`) (list 'quasiquote (sub-read-carefully p))]
[(char-symbolic? c) (sub-read-number-or-symbol c p)]
[(char=? c #\;)
(let loop ([c (read-char p)])
(or (eof-object? c) (char=? c #\newline)
(loop (read-char p))))
(sub-read p)]
[(char=? c #\,)
(let ([next (peek-char p)])
(cond [(eof-object? next)
(r-error p "end of file after ,")]
[(char=? next #\@)
(read-char p)
(list 'unquote-splicing (sub-read-carefully p))]
[else (list 'unquote (sub-read-carefully p))]))]
[(char=? c #\")
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a string")]
[(char=? c #\\)
(let ([e (sub-read-strsym-char-escape p 'string)])
(loop (if e (cons e l) l)))]
[(char=? c #\") (list->string (reverse! l))]
[else (loop (cons c l))])))]
[(char=? c #\|)
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a |symbol|")]
[(char=? c #\\)
(let ([e (sub-read-strsym-char-escape p 'symbol)])
(loop (if e (cons e l) l)))]
[(char=? c #\|) (string->symbol (list->string (reverse! l)))]
[else (loop (cons c l))])))]
[(char=? c #\#)
(let ([c (peek-char p)])
(cond [(eof-object? c) (r-error p "end of file after #")]
[(char=? c #\!)
(read-char p)
(let ([name (sub-read-shebang p)])
(case name
[(fold-case no-fold-case)
(set! fold-case? (eq? name 'fold-case))
(set-port-fold-case! p fold-case?)
(sub-read p)]
[else (if (symbol? name)
(symbol->shebang name)
(r-error p "unexpected name after #!" name))]))]
[(or (char-ci=? c #\t) (char-ci=? c #\f))
(let ([name (sub-read-carefully p)])
(case name [(t true) #t] [(f false) #f]
[else (r-error p "unexpected name after #" name)]))]
[(or (char-ci=? c #\b) (char-ci=? c #\o)
(char-ci=? c #\d) (char-ci=? c #\x)
(char-ci=? c #\i) (char-ci=? c #\e))
(sub-read-number-or-symbol #\# p)]
[(char=? c #\&)
(read-char p)
(box (sub-read-carefully p))]
[(char=? c #\;)
(read-char p)
(sub-read-carefully p)
(sub-read p)]
[(char=? c #\|)
(read-char p)
(let recur () ;starts right after opening #|
(let ([next (read-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\|)
(let ([next (peek-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\#) (read-char p)]
[else (recur)]))]
[(char=? next #\#)
(let ([next (peek-char p)])
(cond
[(eof-object? next)
(r-error p "end of file in #| comment")]
[(char=? next #\|) (read-char p) (recur) (recur)]
[else (recur)]))]
[else (recur)])))
(sub-read p)]
[(char=? c #\() ;)
(read-char p)
(list->vector (sub-read-list c p close-paren #f))]
[(char=? c #\u)
(read-char p)
(if (and (eq? (read-char p) #\8) (eq? (read-char p) #\())
(list->bytevector (sub-read-byte-list p))
(r-error p "invalid bytevector syntax"))]
[(char=? c #\\)
(read-char p)
(let ([c (peek-char p)])
(cond
[(eof-object? c)
(r-error p "end of file after #\\")]
[(char=? #\x c)
(read-char p)
(if (char-delimiter? (peek-char p))
c
(sub-read-x-char-escape p #f))]
[(char-alphabetic? c)
(let ([name (sub-read-carefully p)])
(if (= (string-length (symbol->string name)) 1)
c
(case name
[(null) (integer->char #x00)]
[(space) #\space]
[(alarm) #\alarm]
[(backspace) #\backspace]
[(delete) (integer->char #x7F)] ; todo: support by SFC
[(escape) (integer->char #x1B)]
[(tab) #\tab]
[(newline linefeed) #\newline]
[(vtab) #\vtab]
[(page) #\page]
[(return) #\return]
[else (r-error p "unknown #\\ name" name)])))]
[else (read-char p) c]))]
[(char-numeric? c)
(when simple? (r-error p "#N=/#N# notation is not allowed in this mode"))
(let loop ([l '()])
(let ([c (read-char p)])
(cond [(eof-object? c)
(r-error p "end of file within a #N notation")]
[(char-numeric? c)
(loop (cons c l))]
[(char=? c #\#)
(let* ([s (list->string (reverse! l))] [n (string->number s)])
(cond [(and (fixnum? n) (assq n shared)) => cdr]
[else (r-error "unknown #n# reference:" s)]))]
[(char=? c #\=)
(let* ([s (list->string (reverse! l))] [n (string->number s)])
(cond [(not (fixnum? n)) (r-error "invalid #n= reference:" s)]
[(assq n shared) (r-error "duplicate #n= tag:" n)])
(let ([loc (box #f)])
(set! shared (cons (cons n (make-shared-ref loc)) shared))
(let ([form (sub-read-carefully p)])
(cond [(shared-ref? form) (r-error "#n= has another label as target" s)]
[else (set-box! loc form) form]))))]
[else (r-error p "invalid terminator for #N notation")])))]
[else (r-error p "unknown # syntax" c)]))]
[else (r-error p "illegal character read" c)])))
(define (sub-read-list c p close-token dot?)
(let ([form (sub-read p)])
(if (eq? form dot)
(r-error p "missing car -- ( immediately followed by .") ;)
(let recur ([form form])
(cond [(eof-object? form)
(r-error p "eof inside list -- unbalanced parentheses")]
[(eq? form close-token) '()]
[(eq? form dot)
(if dot?
(let* ([last-form (sub-read-carefully p)]
[another-form (sub-read p)])
(if (eq? another-form close-token)
last-form
(r-error p "randomness after form after dot" another-form)))
(r-error p "dot in #(...)"))]
[(reader-token? form)
(r-error p "error inside list --" (cdr form))]
[else (cons form (recur (sub-read p)))])))))
(define (sub-read-byte-list p)
(let recur ([form (sub-read p)])
(cond [(eof-object? form)
(r-error p "eof inside bytevector")]
[(eq? form close-paren) '()]
[(reader-token? form)
(r-error p "error inside bytevector --" (cdr form))]
[(or (not (fixnum? form)) (fx<? form 0) (fx>? form 255))
(r-error p "invalid byte inside bytevector --" form)]
[else (cons form (recur (sub-read p)))])))
(define (sub-read-strsym-char-escape p what)
(let ([c (read-char p)])
(if (eof-object? c)
(r-error p "end of file within a" what))
(cond [(or (char=? c #\\) (char=? c #\") (char=? c #\|)) c]
[(char=? c #\a) #\alarm]
[(char=? c #\b) #\backspace]
[(char=? c #\t) #\tab]
[(char=? c #\n) #\newline]
[(char=? c #\v) #\vtab]
[(char=? c #\f) #\page]
[(char=? c #\r) #\return]
[(char=? c #\x) (sub-read-x-char-escape p #t)]
[(and (eq? what 'string) (char-whitespace? c))
(let loop ([gotnl (char=? c #\newline)] [nc (peek-char p)])
(cond [(or (eof-object? nc) (not (char-whitespace? nc)))
(if gotnl #f (r-error p "no newline in line ending escape"))]
[(and gotnl (char=? nc #\newline)) #f]
[else (read-char p) (loop (or gotnl (char=? nc #\newline)) (peek-char p))]))]
[else (r-error p "invalid char escape in" what ': c)])))
(define (sub-read-x-char-escape p in-string?)
(define (rev-digits->char l)
(if (null? l)
(r-error p "\\x escape sequence is too short")
(integer->char (string->fixnum (list->string (reverse! l)) 16))))
(let loop ([c (peek-char p)] [l '()] [cc 0])
(cond [(eof-object? c)
(if in-string?
(r-error p "end of file within a string")
(rev-digits->char l))]
[(and in-string? (char=? c #\;))
(read-char p)
(rev-digits->char l)]
[(and (not in-string?) (char-delimiter? c))
(rev-digits->char l)]
[(not (char-hex-digit? c))
(r-error p "unexpected char in \\x escape sequence" c)]
[(> cc 2)
(r-error p "\\x escape sequence is too long")]
[else
(read-char p)
(loop (peek-char p) (cons c l) (+ cc 1))])))
(define (suspect-number-or-symbol-peculiar? hash? c l s)
(cond [(or hash? (char-numeric? c)) #f]
[(or (string-ci=? s "+i") (string-ci=? s "-i")) #f]
[(or (string-ci=? s "+nan.0") (string-ci=? s "-nan.0")) #f]
[(or (string-ci=? s "+inf.0") (string-ci=? s "-inf.0")) #f]
[(or (char=? c #\+) (char=? c #\-))
(cond [(null? (cdr l)) #t]
[(char=? (cadr l) #\.) (and (pair? (cddr l)) (not (char-numeric? (caddr l))))]
[else (not (char-numeric? (cadr l)))])]
[else (and (char=? c #\.) (pair? (cdr l)) (not (char-numeric? (cadr l))))]))
(define (sub-read-number-or-symbol c p)
(let loop ([c (peek-char p)] [l (list c)] [hash? (char=? c #\#)])
(cond [(or (eof-object? c) (char-delimiter? c))
(let* ([l (reverse! l)] [c (car l)] [s (list->string l)])
(if (or hash? (char-numeric? c)
(char=? c #\+) (char=? c #\-) (char=? c #\.))
(cond [(string=? s ".") dot]
[(suspect-number-or-symbol-peculiar? hash? c l s)
(if fold-case?
(string->symbol (string-foldcase s))
(string->symbol s))]
[(string->number s)]
[else (r-error p "unsupported number syntax (implementation restriction)" s)])
(if fold-case?
(string->symbol (string-foldcase s))
(string->symbol s))))]
[(char=? c #\#)
(read-char p)
(loop (peek-char p) (cons c l) #t)]
[(char-symbolic? c)
(read-char p)
(loop (peek-char p) (cons c l) hash?)]
[else (r-error p "unexpected number/symbol char" c)])))
; body of %read
(let ([form (sub-read port)])
(if (not (reader-token? form))
(if (null? shared) form (patch-shared form))
(r-error port "unexpected token:" (cdr form)))))
(define %read
(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 (patch-shared! form)
(cond [(pair? form)
(if (procedure? (car form))
(set-car! form (patch-ref! (car form)))
(patch-shared! (car form)))
(if (procedure? (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)
(vector-set! form i (patch-ref! fi))
(patch-shared! fi)))
(loop (fx+ i 1))))]
[(box? form)
(if (procedure? (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 read
(case-lambda

2
pre/t.scm
View file

@ -2758,7 +2758,7 @@
[help "-h" "--help" #f "Display this help"]
))
(define *skint-version* "0.4.9")
(define *skint-version* "0.6.2")
(define (implementation-version) *skint-version*)
(define (implementation-name) "SKINT")

231
s.c
View file

@ -193,9 +193,9 @@ char *s_code[] = {
":body;;;",
"P", "new-record-type",
"%2'(l1:s6:rtd://;),.2,.2c,,#0.0,&1{%2.0u?{${.3A8,@(y14:%25string-appen"
"d),@(y13:apply-to-list)[02}X5]2}.0du?{.1,.1aX4c,.1d,:0^[22}.1,.1aX4c,'"
"(s1::)c,.1d,:0^[22}.!0.0^_1[22",
"%2'(l1:s6:rtd://;),.2,.2c,,#0.0,&1{%2.0u?{${.3A8,@(y13:string-append),"
"@(y13:apply-to-list)[02}X5]2}.0du?{.1,.1aX4c,.1d,:0^[22}.1,.1aX4c,'(s1"
"::)c,.1d,:0^[22}.!0.0^_1[22",
"S", "%id-eq??",
"l3:y12:syntax-rules;n;l2:l5:y1:_;y2:id;y1:b;y2:kt;y2:kf;;l3:l3:y13:syn"
@ -358,8 +358,8 @@ char *s_code[] = {
"%1.0SfX5]1",
"P", "symbol-append",
"%!0${${.4,@(y14:symbol->string),@(y5:%25map1)[02},@(y14:%25string-appe"
"nd),@(y13:apply-to-list)[02}X5]1",
"%!0${${.4,@(y14:symbol->string),@(y5:%25map1)[02},@(y13:string-append)"
",@(y13:apply-to-list)[02}X5]1",
"P", "substring->list",
"%3n,'1,.4I-,,#0.3,.1,.6,&3{%2:0,.1I<?{.1]2}.1,.1,:2S4c,'1,.2I-,:1^[22}"
@ -411,22 +411,6 @@ char *s_code[] = {
"string->vector)[23}%x,&0{%1.0S3,'0,.2,@(y17:substring->vector)[13}%x,&"
"3{|10|21|32%%}@!(y14:string->vector)",
"P", "strings-sum-length",
"%1'0,.1,,#0.0,&1{%2.0u?{.1]2}.0aS3,.2I+,.1d,:0^[22}.!0.0^_1[12",
"P", "strings-copy-into!",
"%2'0,.2,,#0.0,.4,&2{%2.0u?{:0]2}.0d,.1a,.0S3,${.2,'0,.5,.9,:0,@(y15:su"
"bstring-copy!)[05}.0,.5I+,.3,:1^[52}.!0.0^_1[22",
"P", "%string-append",
"%!0.0,'(c ),${.4,@(y18:strings-sum-length)[01}S2,@(y18:strings-copy-in"
"to!)[12",
"S", "string-append",
"l7:y12:syntax-rules;n;l2:l1:y1:_;;s0:;;l2:l2:y1:_;y1:x;;l2:y4:%25cks;y"
"1:x;;;l2:l3:y1:_;y1:x;y1:y;;l3:y10:string-cat;y1:x;y1:y;;;l2:py1:_;y1:"
"r;;py14:%25string-append;y1:r;;;l2:y1:_;y14:%25string-append;;",
"P", "string-trim-whitespace",
"%1.0S3,'0,,#0.3,.1,&2{%2.1,.1<?{.0,:1S4C1}{f}?{.1,'1,.2+,:0^[22}.1,,#0"
".2,:1,.5,.3,&4{%1:3,.1>?{'1,.1-,:2S4C1}{f}?{'1,.1-,:0^[11}'0,:3=?{:1,."
@ -486,23 +470,6 @@ char *s_code[] = {
"vector->string)[23}%x,&0{%1.0V3,'0,.2,@(y17:subvector->string)[13}%x,&"
"3{|10|21|32%%}@!(y14:vector->string)",
"P", "vectors-sum-length",
"%1'0,.1,,#0.0,&1{%2.0u?{.1]2}.0aV3,.2I+,.1d,:0^[22}.!0.0^_1[12",
"P", "vectors-copy-into!",
"%2'0,.2,,#0.0,.4,&2{%2.0u?{:0]2}.0d,.1a,.0V3,${.2,'0,.5,.9,:0,@(y15:su"
"bvector-copy!)[05}.0,.5I+,.3,:1^[52}.!0.0^_1[22",
"P", "%vector-append",
"%!0.0,f,${.4,@(y18:vectors-sum-length)[01}V2,@(y18:vectors-copy-into!)"
"[12",
"S", "vector-append",
"l7:y12:syntax-rules;n;l2:l1:y1:_;;l2:y5:quote;v0:;;;l2:l2:y1:_;y1:x;;l"
"2:y4:%25ckv;y1:x;;;l2:l3:y1:_;y1:x;y1:y;;l3:y10:vector-cat;y1:x;y1:y;;"
";l2:py1:_;y1:r;;py14:%25vector-append;y1:r;;;l2:y1:_;y14:%25vector-app"
"end;;",
"P", "subbytevector->list",
"%3n,'1,.4I-,,#0.3,.1,.6,&3{%2:0,.1I<?{.1]2}.1,.1,:2B4c,'1,.2I-,:1^[22}"
".!0.0^_1[32",
@ -536,17 +503,6 @@ char *s_code[] = {
"(y19:subbytevector-fill!)[34}%x,&0{%2.0B3,'0,.3,.3,@(y19:subbytevector"
"-fill!)[24}%x,&3{|20|31|42%%}@!(y16:bytevector-fill!)",
"P", "%bytevectors-sum-length",
"%1'0,.1,,#0.0,&1{%2.0u?{.1]2}.0aB3,.2I+,.1d,:0^[22}.!0.0^_1[12",
"P", "%bytevectors-copy-into!",
"%2'0,.2,,#0.0,.4,&2{%2.0u?{:0]2}.0d,.1a,.0B3,${.2,'0,.5,.9,:0,@(y19:su"
"bbytevector-copy!)[05}.0,.5I+,.3,:1^[52}.!0.0^_1[22",
"P", "bytevector-append",
"%!0.0,'0,${.4,@(y23:%25bytevectors-sum-length)[01}B2,@(y23:%25bytevect"
"ors-copy-into!)[12",
"P", "subutf8->string",
"%3P51,${.2,.6,.6,.6,@(y19:write-subbytevector)[04}.0P90,.1P61.0]5",
@ -843,11 +799,6 @@ char *s_code[] = {
"%2.1,&1{%1:0,.1,@(y19:with-output-to-port)[12},.1,@(y21:call-with-outp"
"ut-file)[22",
"P", "read-line",
"%!0P51,.1u?{Pi}{.1a},t,,#0.2,.4,.2,&3{%1:2R0,.0R8,.0?{.0}{'(c%0a),.2C="
"}_1?{.0R8?{.1}{f}?{.0]2}:1P90,:1P61.0]3}'(c%0d),.1C=?{f,:0^[21}:1,.1W0"
"f,:0^[21}.!0.0^_1[31",
"P", "read-substring!",
"%4.1,,#0.5,.4,.4,.3,.8,&5{%1:0,.1I<!?{:3,.1I-]1}:4R0,.0R8?{:3,.2I=?{.0"
"]2}:3,.2I-]2}.0,.2,:2S5'1,.2I+,:1^[21}.!0.0^_1[41",
@ -884,130 +835,54 @@ char *s_code[] = {
"&0{%2.1,.1,@(y18:read-subbytevector)[22}%x,&0{%1Pi,.1,@(y18:read-subby"
"tevector)[12}%x,&2{|10|21%%}@!(y15:read-bytevector)",
"P", "%read",
"%3,,,,,,,,,,,,,,,,,,,,,,,,#0#1#2#3#4#5#6#7#8#9#(i10)#(i11)#(i12)#(i13)"
"#(i14)#(i15)#(i16)#(i17)#(i18)#(i19)#(i20)#(i21)#(i22)#(i23).(i26),.0?"
"{.0}{.(i25)P78}_1.!0n.!1&0{%1.0,&1{%0:0z]0}]1}.!2&0{%1.0K0]1}.!3.4,&1{"
"%1.0K0?{${.2[00},:0^[11}.0]1}.!4.5,.5,&2{%1.0p?{.0aK0?{${.2a,:0^[01},."
"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}.!5.5,&1{%1${.2,:0^[01}.0]1}.!6f.!7f.!8f.!9f.!(i10)'"
"(y12:reader-token),l1,.0.!8'(s17:right parenthesis),.1c.!9'(s13:right "
"bracket),.1c.!(i10)'(s5:%22 . %22),.1c.!(i11)_1.7,&1{%1.0p?{:0^,.1aq]1"
"}f]1}.!(i11)&0{%1'(s80:ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstu"
"vwxyz!$%25&*/:<=>?^_~0123456789+-.@),.1S8]1}.!(i12)&0{%1.0X8,'(i48),.1"
"<!?{'(i57),.1>!}{f},.0?{.0]3}'(i65),.2<!?{'(i70),.2>!}{f},.0?{.0]4}'(i"
"97),.3<!?{'(i102),.3>!]4}f]4}.!(i13)&0{%1.0C1,.0?{.0]2}'(c)),.2C=,.0?{"
".0]3}'(c(),.3C=,.0?{.0]4}'(c]),.4C=,.0?{.0]5}'(c[),.5C=,.0?{.0]6}'(c%2"
"2),.6C=,.0?{.0]7}'(c;),.7C=]7}.!(i14).(i17),.(i12),&2{%1${.2,:1^[01},."
"0R8?{.1,'(y5:port:),'(s22:unexpected end of file),@(y10:read-error)[23"
"}${.2,:0^[01}?{.1,'(y5:port:),.2d,'(s17:unexpected token:),@(y10:read-"
"error)[24}.0]2}.!(i15).(i15),&1{%1'(c ),.1R1v?{${${.4,@(y9:read-line)["
"01},@(y22:string-trim-whitespace)[01}X5]1}.0,:0^[11}.!(i16).9,.(i13),."
"(i22),.3,.(i20),.(i28),.(i23),.(i15),.(i26),.(i28),.(i31),.(i25),.(i15"
"),.(i28),.(i16),.(i16),.(i41),&(i17){%1.0R0,.0R8?{.0]2}.0C1?{.1,:(i10)"
"^[21}'(c(),.1C=?{t,:9^,.3,.3,:8^[24}'(c)),.1C=?{:9^]2}'(c[),.1C=?{t,:("
"i16)^,.3,.3,:8^[24}'(c]),.1C=?{:(i16)^]2}'(c'),.1C=?{${.3,:3^[01},'(y5"
":quote),l2]2}'(c`),.1C=?{${.3,:3^[01},'(y10:quasiquote),l2]2}${.2,:(i1"
"5)^[01}?{.1,.1,:(i11)^[22}'(c;),.1C=?{${.3R0,,#0.5,.1,&2{%1.0R8,.0?{.0"
"]2}'(c%0a),.2C=,.0?{.0]3}:1R0,:0^[31}.!0.0^_1[01}.1,:(i10)^[21}'(c,),."
"1C=?{.1R1,.0R8?{.2,'(y5:port:),'(s19:end of file after ,),@(y10:read-e"
"rror)[33}'(c@),.1C=?{.2R0${.4,:3^[01},'(y16:unquote-splicing),l2]3}${."
"4,:3^[01},'(y7:unquote),l2]3}'(c%22),.1C=?{n,,#0.3,:(i14),.2,&3{%1:2R0"
",.0R8?{:2,'(y5:port:),'(s27:end of file within a string),@(y10:read-er"
"ror)[23}'(c%5c),.1C=?{${'(y6:string),:2,:1^[02},.0?{.2,.1c}{.2},:0^[31"
"}'(c%22),.1C=?{.1A9X3]2}.1,.1c,:0^[21}.!0.0^_1[21}'(c|),.1C=?{n,,#0.3,"
":(i14),.2,&3{%1:2R0,.0R8?{:2,'(y5:port:),'(s29:end of file within a |s"
"ymbol|),@(y10:read-error)[23}'(c%5c),.1C=?{${'(y6:symbol),:2,:1^[02},."
"0?{.2,.1c}{.2},:0^[31}'(c|),.1C=?{.1A9X3X5]2}.1,.1c,:0^[21}.!0.0^_1[21"
"}'(c#),.1C=?{.1R1,.0R8?{.2,'(y5:port:),'(s19:end of file after #),@(y1"
"0:read-error)[33}'(c!),.1C=?{.2R0${.4,:(i12)^[01},.0,'(l2:y9:fold-case"
";y12:no-fold-case;),.1A1?{'(y9:fold-case),.2q:!(i13):(i13)^,.5P79.4,:("
"i10)^[51}.1Y0?{.1Y6]5}.4,'(y5:port:),.3,'(s24:unexpected name after #!"
"),@(y10:read-error)[54}'(ct),.1Ci=,.0?{.0}{'(cf),.2Ci=}_1?{${.4,:3^[01"
"},.0,'(l2:y1:t;y4:true;),.1A1?{t]5}'(l2:y1:f;y5:false;),.1A1?{f]5}.4,'"
"(y5:port:),.3,'(s23:unexpected name after #),@(y10:read-error)[54}'(cb"
"),.1Ci=,.0?{.0}{'(co),.2Ci=,.0?{.0}{'(cd),.3Ci=,.0?{.0}{'(cx),.4Ci=,.0"
"?{.0}{'(ci),.5Ci=,.0?{.0}{'(ce),.6Ci=}_1}_1}_1}_1}_1?{.2,'(c#),:(i11)^"
"[32}'(c&),.1C=?{.2R0${.4,:3^[01}b]3}'(c;),.1C=?{.2R0${.4,:3^[01}.2,:(i"
"10)^[31}'(c|),.1C=?{.2R0${,#0.5,.1,&2{%0:1R0,.0R8?{:1,'(y5:port:),'(s2"
"5:end of file in #| comment),@(y10:read-error)[13}'(c|),.1C=?{:1R1,.0R"
"8?{:1,'(y5:port:),'(s25:end of file in #| comment),@(y10:read-error)[2"
"3}'(c#),.1C=?{:1R0]2}:0^[20}'(c#),.1C=?{:1R1,.0R8?{:1,'(y5:port:),'(s2"
"5:end of file in #| comment),@(y10:read-error)[23}'(c|),.1C=?{:1R0${:0"
"^[00}:0^[20}:0^[20}:0^[10}.!0.0^_1[00}.2,:(i10)^[31}'(c(),.1C=?{.2R0${"
"f,:9^,.6,.5,:8^[04}X1]3}'(cu),.1C=?{.2R0'(c8),.3R0q?{'(c(),.3R0q}{f}?{"
"${.4,:7^[01}E1]3}.2,'(y5:port:),'(s25:invalid bytevector syntax),@(y10"
":read-error)[33}'(c%5c),.1C=?{.2R0.2R1,.0R8?{.3,'(y5:port:),'(s20:end "
"of file after #%5c),@(y10:read-error)[43}.0,'(cx)C=?{.3R0${.5R1,:5^[01"
"}?{.0]4}f,.4,:6^[42}.0C4?{${.5,:3^[01},'1,.1X4S3=?{.1]5}.0,'(y4:null),"
".1v?{'0X9]6}'(y5:space),.1v?{'(c )]6}'(y5:alarm),.1v?{'(c%07)]6}'(y9:b"
"ackspace),.1v?{'(c%08)]6}'(y6:delete),.1v?{'(i127)X9]6}'(y6:escape),.1"
"v?{'(i27)X9]6}'(y3:tab),.1v?{'(c%09)]6}'(l2:y7:newline;y8:linefeed;),."
"1A1?{'(c%0a)]6}'(y4:vtab),.1v?{'(c%0b)]6}'(y4:page),.1v?{'(c%0c)]6}'(y"
"6:return),.1v?{'(c%0d)]6}.5,'(y5:port:),.3,'(s15:unknown #%5c name),@("
"y10:read-error)[64}.3R0.0]4}.0C5?{:0?{${.4,'(y5:port:),'(s44:#N=/#N# n"
"otation is not allowed in this mode),@(y10:read-error)[03}}n,,#0.4,.1,"
":4,:3,:2,:1,&6{%1:5R0,.0R8?{:5,'(y5:port:),'(s32:end of file within a "
"#N notation),@(y10:read-error)[23}.0C5?{.1,.1c,:4^[21}'(c#),.1C=?{.1A9"
"X3,'(i10),.1E9,.0I0?{:0^,.1A3}{f},.0?{.0d]5}'(s22:unknown #n# referenc"
"e:),'(y5:port:),.4,@(y10:read-error)[53}'(c=),.1C=?{.1A9X3,'(i10),.1E9"
",.0I0~?{${'(s22:invalid #n= reference:),'(y5:port:),.5,@(y10:read-erro"
"r)[03}}{:0^,.1A3?{${'(s18:duplicate #n= tag:),'(y5:port:),.4,@(y10:rea"
"d-error)[03}}{f}}fb,:0^,${.3,:1^[01},.3cc:!0${:5,:2^[01},${.2,:3^[01}?"
"{'(s31:#n= has another label as target),'(y5:port:),.5,@(y10:read-erro"
"r)[63}.0,.2sz.0]6}:5,'(y5:port:),'(s34:invalid terminator for #N notat"
"ion),@(y10:read-error)[23}.!0.0^_1[31}.2,'(y5:port:),.2,'(s16:unknown "
"# syntax),@(y10:read-error)[34}.1,'(y5:port:),.2,'(s22:illegal charact"
"er read),@(y10:read-error)[24}.!(i17).(i17),.(i12),.(i17),.(i13),&4{%4"
"${.3,:3^[01},:0^,.1q?{.2,'(y5:port:),'(s42:missing car -- ( immediatel"
"y followed by .),@(y10:read-error)[53}.0,,#0.0,.5,:3,:2,.(i10),:1,.(i1"
"1),:0,&8{%1.0R8?{:6,'(y5:port:),'(s41:eof inside list -- unbalanced pa"
"rentheses),@(y10:read-error)[13}:1,.1q?{n]1}:0^,.1q?{:3?{${:6,:2^[01},"
"${:6,:5^[01},:1,.1q?{.1]3}:6,'(y5:port:),.2,'(s31:randomness after for"
"m after dot),@(y10:read-error)[34}:6,'(y5:port:),'(s13:dot in #(...)),"
"@(y10:read-error)[13}${.2,:4^[01}?{:6,'(y5:port:),.2d,'(s20:error insi"
"de list --),@(y10:read-error)[14}${${:6,:5^[01},:7^[01},.1c]1}.!0.0^_1"
"[51}.!(i18).(i17),.9,.(i13),&3{%1${.2,:2^[01},,#0.0,.3,:2,:0,:1,&5{%1."
"0R8?{:3,'(y5:port:),'(s21:eof inside bytevector),@(y10:read-error)[13}"
":0^,.1q?{n]1}${.2,:1^[01}?{:3,'(y5:port:),.2d,'(s26:error inside bytev"
"ector --),@(y10:read-error)[14}.0I0~,.0?{.0}{'0,.2I<,.0?{.0}{'(i255),."
"3I>}_1}_1?{:3,'(y5:port:),.2,'(s33:invalid byte inside bytevector --),"
"@(y10:read-error)[14}${${:3,:2^[01},:4^[01},.1c]1}.!0.0^_1[11}.!(i19)."
"(i21),&1{%2.0R0,.0R8?{${.3,'(y5:port:),.6,'(s20:end of file within a),"
"@(y10:read-error)[04}}'(c%5c),.1C=,.0?{.0}{'(c%22),.2C=,.0?{.0}{'(c|),"
".3C=}_1}_1?{.0]3}'(ca),.1C=?{'(c%07)]3}'(cb),.1C=?{'(c%08)]3}'(ct),.1C"
"=?{'(c%09)]3}'(cn),.1C=?{'(c%0a)]3}'(cv),.1C=?{'(c%0b)]3}'(cf),.1C=?{'"
"(c%0c)]3}'(cr),.1C=?{'(c%0d)]3}'(cx),.1C=?{t,.2,:0^[32}'(y6:string),.3"
"q?{.0C1}{f}?{.1R1,'(c%0a),.2C=,,#0.0,.5,&2{%2.1R8,.0?{.0}{.2C1~}_1?{.0"
"?{f]2}:0,'(y5:port:),'(s32:no newline in line ending escape),@(y10:rea"
"d-error)[23}.0?{'(c%0a),.2C=}{f}?{f]2}:0R0:0R1,.1,.0?{.0}{'(c%0a),.4C="
"}_1,:1^[22}.!0.0^_1[32}.1,'(y5:port:),.2,'(y1::),.6,'(s22:invalid char"
" escape in),@(y10:read-error)[36}.!(i20).(i14),.(i14),&2{%2,#0.1,&1{%1"
".0u?{:0,'(y5:port:),'(s31:%5cx escape sequence is too short),@(y10:rea"
"d-error)[13}'(i16),.1A9X3X7X9]1}.!0'0,n,.3R1,,#0.0,.6,:0,.7,.(i10),:1,"
"&6{%3.0R8?{:1?{:4,'(y5:port:),'(s27:end of file within a string),@(y10"
":read-error)[33}.1,:2^[31}:1?{'(c;),.1C=}{f}?{:4R0.1,:2^[31}:1~?{${.2,"
":0^[01}}{f}?{.1,:2^[31}${.2,:3^[01}~?{:4,'(y5:port:),.2,'(s37:unexpect"
"ed char in %5cx escape sequence),@(y10:read-error)[34}'2,.3>?{:4,'(y5:"
"port:),'(s30:%5cx escape sequence is too long),@(y10:read-error)[33}:4"
"R0'1,.3+,.2,.2c,:4R1,:5^[33}.!0.0^_1[33}.!(i21)&0{%4.0,.0?{.0}{.2C5}_1"
"?{f]4}'(s2:+i),.4Si=,.0?{.0}{'(s2:-i),.5Si=}_1?{f]4}'(s6:+nan.0),.4Si="
",.0?{.0}{'(s6:-nan.0),.5Si=}_1?{f]4}'(s6:+inf.0),.4Si=,.0?{.0}{'(s6:-i"
"nf.0),.5Si=}_1?{f]4}'(c+),.2C=,.0?{.0}{'(c-),.3C=}_1?{.2du?{t]4}'(c.),"
".3daC=?{.2ddp?{.2ddaC5~]4}f]4}.2daC5~]4}'(c.),.2C=?{.2dp?{.2daC5~]4}f]"
"4}f]4}.!(i22).(i14),.(i23),.(i12),.3,.(i16),&5{%2'(c#),.1C=,.1,l1,.3R1"
",,#0.5,.1,:0,:1,:2,:3,:4,&7{%3.0R8,.0?{.0}{${.3,:0^[01}}_1?{.1A9,.0a,."
"1X3,.5,.0?{.0}{.2C5,.0?{.0}{'(c+),.4C=,.0?{.0}{'(c-),.5C=,.0?{.0}{'(c."
"),.6C=}_1}_1}_1}_1?{'(s1:.),.1S=?{:2^]6}${.2,.5,.5,.(i10),:1^[04}?{:3^"
"?{.0SfX5]6}.0X5]6}'(i10),.1E9,.0?{.0]7}:6,'(y5:port:),.3,'(s54:unsuppo"
"rted number syntax (implementation restriction)),@(y10:read-error)[74}"
":3^?{.0SfX5]6}.0X5]6}'(c#),.1C=?{:6R0t,.2,.2c,:6R1,:5^[33}${.2,:4^[01}"
"?{:6R0.2,.2,.2c,:6R1,:5^[33}:6,'(y5:port:),.2,'(s29:unexpected number/"
"symbol char),@(y10:read-error)[34}.!0.0^_1[23}.!(i23)${.(i26),.(i20)^["
"01},${.2,.(i15)^[01}~?{.2^u?{.0](i28)}.0,.8^[(i28)1}.(i25),'(y5:port:)"
",.2d,'(s17:unexpected token:),@(y10:read-error)[(i28)4",
"]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)",
"C", 0,
"&0{%1f,f,.2,@(y5:%25read)[13}%x,&0{%0f,f,Pi,@(y5:%25read)[03}%x,&2{|00"
@ -1152,9 +1027,9 @@ char *s_code[] = {
"?{.7d,${'2,.7,@(y11:string-copy)[02},.3^d,.(i12)[(i10)3}.1^?{.1^a?{'2,"
".3=?{.7dp}{f}}{f}}{f}?{.7dd,.8da,.3^d,.(i12)[(i10)3}.1^?{.1^a}{f}?{.0^"
",'(s23:missing option argument),.6^[(i10)2}.1^?{.1^a~?{'2,.3>}{f}}{f}?"
"{.7d,${'2,.7,@(y11:string-copy)[02},'(s1:-)S6c,f,.3^d,.(i12)[(i10)3}.1"
"^?{.1^a~}{f}?{.7d,f,.3^d,.(i12)[(i10)3}.0^,'(s14:unknown option),.6^[("
"i10)2",
"{.7d,${'2,.7,@(y11:string-copy)[02},'(s1:-),Sa2c,f,.3^d,.(i12)[(i10)3}"
".1^?{.1^a~}{f}?{.7d,f,.3^d,.(i12)[(i10)3}.0^,'(s14:unknown option),.6^"
"[(i10)2",
"P", "print-command-line-options",
"%!1,,,,#0#1#2#3.4p?{.4a}{P11}.!0&0{%1.0ddda,.1dda,.2da,,,,#0#1#2.3?{.3"

105
t.c
View file

@ -62,8 +62,8 @@ char *t_code[] = {
"sexp-case;y3:key;y6:clause;y7:clauses;y3:...;;;;",
"C", 0,
"'0,#0.0,&1{%!0'1,:0^I+:!0.0u,.0?{.0}{.1aY0~}_1?{'(i10),:0^X6,'(s1:#)S6"
"X5]1}'(i10),:0^X6,'(s1:#)S6,.1aX4S6X5]1}_1@!(y6:gensym)",
"'0,#0.0,&1{%!0'1,:0^I+:!0.0u,.0?{.0}{.1aY0~}_1?{'(i10),:0^X6,'(s1:#),S"
"a2X5]1}'(i10),:0^X6,'(s1:#),Sa2,.1aX4,Sa2X5]1}_1@!(y6:gensym)",
"P", "remove!",
"%3.1,f,f,,#0.0,.7,.6,&3{%3.2p~?{.1?{.2,.2sd.0]3}.2]3}${.4a,:0,:1[02}?{"
@ -77,7 +77,7 @@ char *t_code[] = {
"%1.0u?{n]1}.0du?{.0a]1}${.2d,@(y7:append*)[01},.1aL6]1",
"P", "string-append*",
"%1.0,@(y14:%25string-append),@(y13:apply-to-list)[12",
"%1.0,@(y13:string-append),@(y13:apply-to-list)[12",
"P", "list1?",
"%1.0p?{.0du]1}f]1",
@ -108,7 +108,7 @@ char *t_code[] = {
"%2${.3,.3,f,@(y12:error-object)[03},@(y5:raise)[21",
"P", "warning*",
"%2Pe,.2,.2,'(s9:Warning: )S6,@(y19:print-error-message)[23",
"%2Pe,.2,.2,'(s9:Warning: ),Sa2,@(y19:print-error-message)[23",
"P", "idslist?",
"%1.0u?{t]1}.0p?{${.2a,@(y3:id?)[01}?{.0d,@(y8:idslist?)[11}f]1}.0,@(y3"
@ -225,7 +225,7 @@ char *t_code[] = {
"0^_1[11",
"P", "x-error",
"%!1.0,.2,'(s13:transformer: )S6,@(y6:error*)[22",
"%!1.0,.2,'(s13:transformer: ),Sa2,@(y6:error*)[22",
"P", "check-syntax",
"%3${.2,.4,@(y11:sexp-match?)[02}~?{.0,.3,@(y7:x-error)[32}]3",
@ -465,23 +465,23 @@ char *t_code[] = {
"ake-list),.3,.5[02}?{&0{%1${'(s31:invalid make-list template args),'(l"
"2:y8:<number>;y1:*;),.4,@(y12:check-syntax)[03}.0da,.1aL2]1}]2}${'(y13"
":string-append),.3,.5[02}?{&0{%1${'(s35:invalid string-append template"
" args),'(l2:y8:<string>;y3:...;),.4,@(y12:check-syntax)[03}.0,@(y14:%2"
"5string-append),@(y13:apply-to-list)[12}]2}${'(y7:char<=?),.3,.5[02}?{"
"&0{%1${'(s29:invalid char<=? template args),'(l2:y6:<char>;y3:...;),.4"
",@(y12:check-syntax)[03}.0,@(y1:<),@(y13:apply-to-list)[12}]2}${'(y2:<"
"=),.3,.5[02}?{&0{%1${'(s24:invalid <= template args),'(l2:y8:<number>;"
"y3:...;),.4,@(y12:check-syntax)[03}.0,@(y1:<),@(y13:apply-to-list)[12}"
"]2}${'(y1:+),.3,.5[02}?{&0{%1${'(s23:invalid + template args),'(l2:y8:"
"<number>;y3:...;),.4,@(y12:check-syntax)[03}.0,@(y1:+),@(y13:apply-to-"
"list)[12}]2}${'(y1:-),.3,.5[02}?{&0{%1${'(s23:invalid - template args)"
",'(l2:y8:<number>;y3:...;),.4,@(y12:check-syntax)[03}.0,@(y1:-),@(y13:"
"apply-to-list)[12}]2}${'(y10:id->string),.3,.5[02}?{&0{%1${'(s32:inval"
"id id->string template args),'(l1:y4:<id>;),.4,@(y12:check-syntax)[03}"
"${.2a,@(y7:id->sym)[01}X4]1}]2}${'(y10:string->id),.3,.5[02}?{.0,&1{%1"
"${.2,'(l1:y8:<string>;),@(y11:sexp-match?)[02}?{.0aX5,:0,@(y12:id-rena"
"me-as)[12}${.2,'(l2:y8:<string>;y4:<id>;),@(y11:sexp-match?)[02}?{.0aX"
"5,.1da,@(y12:id-rename-as)[12}'(s32:invalid string->id template args),"
"@(y7:x-error)[11}]2}f]2",
" args),'(l2:y8:<string>;y3:...;),.4,@(y12:check-syntax)[03}.0,@(y13:st"
"ring-append),@(y13:apply-to-list)[12}]2}${'(y7:char<=?),.3,.5[02}?{&0{"
"%1${'(s29:invalid char<=? template args),'(l2:y6:<char>;y3:...;),.4,@("
"y12:check-syntax)[03}.0,@(y1:<),@(y13:apply-to-list)[12}]2}${'(y2:<=),"
".3,.5[02}?{&0{%1${'(s24:invalid <= template args),'(l2:y8:<number>;y3:"
"...;),.4,@(y12:check-syntax)[03}.0,@(y1:<),@(y13:apply-to-list)[12}]2}"
"${'(y1:+),.3,.5[02}?{&0{%1${'(s23:invalid + template args),'(l2:y8:<nu"
"mber>;y3:...;),.4,@(y12:check-syntax)[03}.0,@(y1:+),@(y13:apply-to-lis"
"t)[12}]2}${'(y1:-),.3,.5[02}?{&0{%1${'(s23:invalid - template args),'("
"l2:y8:<number>;y3:...;),.4,@(y12:check-syntax)[03}.0,@(y1:-),@(y13:app"
"ly-to-list)[12}]2}${'(y10:id->string),.3,.5[02}?{&0{%1${'(s32:invalid "
"id->string template args),'(l1:y4:<id>;),.4,@(y12:check-syntax)[03}${."
"2a,@(y7:id->sym)[01}X4]1}]2}${'(y10:string->id),.3,.5[02}?{.0,&1{%1${."
"2,'(l1:y8:<string>;),@(y11:sexp-match?)[02}?{.0aX5,:0,@(y12:id-rename-"
"as)[12}${.2,'(l2:y8:<string>;y4:<id>;),@(y11:sexp-match?)[02}?{.0aX5,."
"1da,@(y12:id-rename-as)[12}'(s32:invalid string->id template args),@(y"
"7:x-error)[11}]2}f]2",
"P", "syntax-rules*",
"%4,,,,,,,,,,,,#0#1#2#3#4#5#6#7#8#9#(i10)#(i11).(i14),&1{%1:0,.1A0]1}.!"
@ -760,10 +760,10 @@ char *t_code[] = {
")S4W0]2}.1,'(c()W0${.3,.3,@(y21:write-serialized-sexp)[02}.1,'(c))W0]2",
"P", "c-error",
"%!1.0,.2,'(s10:compiler: )S6,@(y6:error*)[22",
"%!1.0,.2,'(s10:compiler: ),Sa2,@(y6:error*)[22",
"P", "c-warning",
"%!1.0,.2,'(s10:compiler: )S6,@(y8:warning*)[22",
"%!1.0,.2,'(s10:compiler: ),Sa2,@(y8:warning*)[22",
"P", "find-free*",
"%2.0u?{n]2}${.3,.3d,@(y10:find-free*)[02},${.4,.4a,@(y9:find-free)[02}"
@ -988,7 +988,7 @@ char *t_code[] = {
"P", "file-resolve-relative-to-base-path",
"%2${.2,@(y14:path-relative?)[01}?{${.3,@(y19:base-path-separator)[01}?"
"{.0,.2S6]2}.0,Zs,S11,.3,@(y14:%25string-append)[23}.0]2",
"{.0,.2,Sa2]2}.0,Zs,S11,.3,Sa3]2}.0]2",
"C", 0,
"n@!(y20:*current-file-stack*)",
@ -1034,16 +1034,16 @@ char *t_code[] = {
"P", "mangle-symbol->string",
"%1,#0'(l5:c!;c$;c-;c_;c=;).!0n,.2X4X2,,#0.0,.4,&2{%2.0u?{.1A8X3]2}.0aC"
"2,.0?{.0}{.1aC5}_1?{.1,.1ac,.1d,:1^[22}:0^,.1aA1?{.1,.1ac,.1d,:1^[22}'"
"(i16),.1aX8E8,'2,.1S3<?{.0,'(s1:0)S6}{.0},.0SdX2,'(c%25)c,.4,.1A8L6,.4"
"d,:1^[52}.!0.0^_1[22",
"(i16),.1aX8E8,'2,.1S3<?{.0,'(s1:0),Sa2}{.0},.0SdX2,'(c%25)c,.4,.1A8L6,"
".4d,:1^[52}.!0.0^_1[22",
"P", "listname->symbol",
"%1,,,,#0#1#2#3'(s0:).!0'(s5:lib:/).!1'(s1:/).!2'(s1:/).!3.4L0~?{${.6,'"
"(s20:invalid library name),@(y7:x-error)[02}}.1^,l1,.5,,#0.7,.1,.8,.8,"
".7,&5{%2.0u?{${.3,:0^cA8,@(y14:%25string-append),@(y13:apply-to-list)["
"02}X5]2}.0aY0?{.1,:1^c,${.3a,@(y21:mangle-symbol->string)[01}c,.1d,:3^"
"[22}.0aI0?{.1,:2^c,'(i10),.2aE8c,.1d,:3^[22}:4,'(s20:invalid library n"
"ame),@(y7:x-error)[22}.!0.0^_1[52",
".7,&5{%2.0u?{${.3,:0^cA8,@(y13:string-append),@(y13:apply-to-list)[02}"
"X5]2}.0aY0?{.1,:1^c,${.3a,@(y21:mangle-symbol->string)[01}c,.1d,:3^[22"
"}.0aI0?{.1,:2^c,'(i10),.2aE8c,.1d,:3^[22}:4,'(s20:invalid library name"
"),@(y7:x-error)[22}.!0.0^_1[52",
"P", "listname-segment->string",
"%1.0Y0?{.0,@(y21:mangle-symbol->string)[11}.0I0?{'(i10),.1E8]1}.0,'(s3"
@ -1060,12 +1060,12 @@ char *t_code[] = {
"Zd,l1@!(y19:*library-path-list*)",
"P", "append-library-path!",
"%1#0${.2^,@(y19:base-path-separator)[01}~?{Zs,S11,.1^S6.!0}.0^,l1,@(y1"
"9:*library-path-list*)L6@!(y19:*library-path-list*)]1",
"%1#0${.2^,@(y19:base-path-separator)[01}~?{Zs,S11,.1^,Sa2.!0}.0^,l1,@("
"y19:*library-path-list*)L6@!(y19:*library-path-list*)]1",
"P", "prepend-library-path!",
"%1#0${.2^,@(y19:base-path-separator)[01}~?{Zs,S11,.1^S6.!0}@(y19:*libr"
"ary-path-list*),.1^,l1L6@!(y19:*library-path-list*)]1",
"%1#0${.2^,@(y19:base-path-separator)[01}~?{Zs,S11,.1^,Sa2.!0}@(y19:*li"
"brary-path-list*),.1^,l1L6@!(y19:*library-path-list*)]1",
"P", "find-library-path",
"%1@(y19:*library-path-list*),,#0.0,.3,&2{%1.0p?{${'(s4:.sld),.3a,:0,@("
@ -1573,12 +1573,12 @@ char *t_code[] = {
"le),@(y5:error)[02}}_1}${.6R1,,#0.8,.1,&2{%1'(l2:c%0a;c%0d;),.1A1?{:1R"
"0:1R1,:0^[11}]1}.!0.0^_1[01}'1,,#0.3,.7,.6,.3,.(i11),.7,.(i11),&7{%1:5"
"R1R8~?{,,,,#0#1#2#3:5R0.!0:5R0.!1:5R0.!2.2^,.2^,.2^,l3.!3'(l3:cC;c%09;"
"c%09;),.4^e?{${${:5,@(y9:read-line)[01},:6^[01}'1,.5+,:3^[51}'(cP),.1^"
"v?{'(c%09),.2^v?{.2^R8~}{f}}{f}?{.2^,l1,:5R0,,#0:5,.1,:3,.(i10),:4,:0,"
"&6{%2.0R8?{'(y3:eof),:2,:0^[22}'(c%09),.1v?{,#0.2A9X3X5.!0${${:5,@(y9:"
"read-line)[01},.3^,:1^[02}'1,:2+,:3^[31}.1,.1c,:5R0,:4^[22}.!0.0^_1[52"
"}'(l3:cM;c%09;c%09;),.4^e?{:2p?{:1^,n,n,:2c,'(y5:quote)cc,'(y4:main)c,"
"@(y4:eval)[52}f]5}.3^,.5,:0^[52}]1}.!0.0^_1[61",
"c%09;),.4^e?{${:5R6,:6^[01}'1,.5+,:3^[51}'(cP),.1^v?{'(c%09),.2^v?{.2^"
"R8~}{f}}{f}?{.2^,l1,:5R0,,#0:5,.1,:3,.(i10),:4,:0,&6{%2.0R8?{'(y3:eof)"
",:2,:0^[22}'(c%09),.1v?{,#0.2A9X3X5.!0${:5R6,.3^,:1^[02}'1,:2+,:3^[31}"
".1,.1c,:5R0,:4^[22}.!0.0^_1[52}'(l3:cM;c%09;c%09;),.4^e?{:2p?{:1^,n,n,"
":2c,'(y5:quote)cc,'(y4:main)c,@(y4:eval)[52}f]5}.3^,.5,:0^[52}]1}.!0.0"
"^_1[61",
"P", "run-fasl",
"%2,#0.2,.2c.!0.0,&1{%1:0^,.1,@(y18:run-fasl-from-port)[12},.2,@(y28:ca"
@ -1691,17 +1691,16 @@ char *t_code[] = {
"(i11),&5{%0:4,&1{%!0.0,&1{%0:0,@(y6:values),@(y13:apply-to-list)[02},:"
"0[11},:0,:1,:2,:3,&4{%0${:1,:2,:3,@(y9:repl-read)[03},,#0:0,:3,:2,:1,."
"4,&5{%1.0R8~?{:2?{${.2,'(l2:y7:unquote;y1:*;),@(y11:sexp-match?)[02}}{"
"f}?{${:1,${:3,@(y9:read-line)[01},.4da,@(y17:repl-exec-command)[03}}{$"
"{:1,:4,.4,@(y22:repl-evaluate-top-form)[03}}${:1,:2,:3,@(y9:repl-read)"
"[03},:0^[11}]1}.!0.0^_1[01},@(y16:call-with-values)[02},.(i11),.(i11),"
".(i11),.(i11),.(i11),.8,&6{%1${k0,.0,${.6,:1,:2,:3,:4,:5,&6{%0:5,${.2,"
"@(y13:error-object?)[01}?{Pe,.0,${.4,@(y20:error-object-message)[01}W4"
".0W6${${.5,@(y22:error-object-irritants)[01},.3,&1{%1:0,.1W5:0W6]1},@("
"y10:%25for-each1)[02}_1${:4^,@(y23:set-current-file-stack!)[01}:1?{:0,"
":1,:2,:3,@(y14:repl-from-port)[14}]1}Pe,.0,'(s14:Unknown error:)W4.0W6"
".0,.2W5.0W6_1${:4^,@(y23:set-current-file-stack!)[01}:1?{:0,:1,:2,:3,@"
"(y14:repl-from-port)[14}]1},:0[01}_1_3}[10},@(y22:with-exception-handl"
"er)[02}_1_3}[50",
"f}?{${:1,:3R6,.4da,@(y17:repl-exec-command)[03}}{${:1,:4,.4,@(y22:repl"
"-evaluate-top-form)[03}}${:1,:2,:3,@(y9:repl-read)[03},:0^[11}]1}.!0.0"
"^_1[01},@(y16:call-with-values)[02},.(i11),.(i11),.(i11),.(i11),.(i11)"
",.8,&6{%1${k0,.0,${.6,:1,:2,:3,:4,:5,&6{%0:5,${.2,@(y13:error-object?)"
"[01}?{Pe,.0,${.4,@(y20:error-object-message)[01}W4.0W6${${.5,@(y22:err"
"or-object-irritants)[01},.3,&1{%1:0,.1W5:0W6]1},@(y10:%25for-each1)[02"
"}_1${:4^,@(y23:set-current-file-stack!)[01}:1?{:0,:1,:2,:3,@(y14:repl-"
"from-port)[14}]1}Pe,.0,'(s14:Unknown error:)W4.0W6.0,.2W5.0W6_1${:4^,@"
"(y23:set-current-file-stack!)[01}:1?{:0,:1,:2,:3,@(y14:repl-from-port)"
"[14}]1},:0[01}_1_3}[10},@(y22:with-exception-handler)[02}_1_3}[50",
"P", "run-benchmark",
"%2,,#0#1${.4,@(y15:open-input-file)[01}.!0Po.!1${${.4^,@(y14:read-code"
@ -1737,7 +1736,7 @@ char *t_code[] = {
"kint-options*)",
"C", 0,
"'(s5:0.4.9)@!(y15:*skint-version*)",
"'(s5:0.6.2)@!(y15:*skint-version*)",
"P", "implementation-version",
"%0@(y15:*skint-version*)]0",