From 5285131672d3dba72a85628db44b0efd8b3da615 Mon Sep 17 00:00:00 2001 From: ESL Date: Thu, 29 Aug 2024 17:54:17 -0400 Subject: [PATCH] faster read --- i.c | 153 ++++++++++-- i.h | 16 +- misc/Skint-prelude.scm | 1 + n.c | 525 ++++++++++++++++++++++++++++++++++++--- n.h | 30 ++- pre/n.sf | 537 +++++++++++++++++++++++++++++++++++++--- pre/s.scm | 548 +++++++++-------------------------------- pre/t.scm | 2 +- s.c | 231 ++++------------- t.c | 105 ++++---- 10 files changed, 1375 insertions(+), 773 deletions(-) diff --git a/i.c b/i.c index f777d2d..fbb4cac 100644 --- a/i.c +++ b/i.c @@ -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(); } diff --git a/i.h b/i.h index 956451d..2aa3c32 100644 --- a/i.h +++ b/i.h @@ -396,14 +396,15 @@ declare_instruction(cigt, "Ci>", 0, "char-ci>?", declare_instruction(cile, "Ci>!", 0, "char-ci<=?", 'c', AUTOGL) declare_instruction(cige, "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=?", '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) diff --git a/misc/Skint-prelude.scm b/misc/Skint-prelude.scm index e69de29..efe31ba 100644 --- a/misc/Skint-prelude.scm +++ b/misc/Skint-prelude.scm @@ -0,0 +1 @@ +(import (only (skint) implementation-version)) diff --git a/n.c b/n.c index ab7b69c..df075fc 100644 --- a/n.c +++ b/n.c @@ -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; +} diff --git a/n.h b/n.h index a786fde..ca59fa1 100644 --- a/n.h +++ b/n.h @@ -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); diff --git a/pre/n.sf b/pre/n.sf index c897dcf..dfa691a 100644 --- a/pre/n.sf +++ b/pre/n.sf @@ -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; +} ") diff --git a/pre/s.scm b/pre/s.scm index f9c4749..a5c7fb0 100644 --- a/pre/s.scm +++ b/pre/s.scm @@ -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?^_~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 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 (fxsymbol (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 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 diff --git a/pre/t.scm b/pre/t.scm index 3346ca1..bdd4d71 100644 --- a/pre/t.scm +++ b/pre/t.scm @@ -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") diff --git a/s.c b/s.c index f9558f6..ea675b7 100644 --- a/s.c +++ b/s.c @@ -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,.1Ivector)[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?{'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,.1Istring", "%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?^_~0123456789+-.@),.1S8]1}.!(i12)&0{%1.0X8,'(i48),.1" - "!}{f},.0?{.0]3}'(i65),.2!}{f},.0?{.0]4}'(i" - "97),.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" diff --git a/t.c b/t.c index 0146d19..3105d4a 100644 --- a/t.c +++ b/t.c @@ -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:;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:;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:;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:;" - "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:" - ";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:;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:;),.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:;),@(y11:sexp-match?)[02}?{.0aX5,:0,@(y12:id-rena" - "me-as)[12}${.2,'(l2:y8:;y4:;),@(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:;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:;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:;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:;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:;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:;),.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:;),@(y11:sexp-match?)[02}?{.0aX5,:0,@(y12:id-rename-" + "as)[12}${.2,'(l2:y8:;y4:;),@(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,.1S3symbol", "%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",