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