diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index 7ae471c..e41874d 100644 --- a/femtolisp/cps.lsp +++ b/femtolisp/cps.lsp @@ -17,7 +17,7 @@ ,(begin->cps (cdr forms) k))))))) (define-macro (lambda/cc args body) - `(rplaca (lambda ,args ,body) 'lambda/cc)) + `(set-car! (lambda ,args ,body) 'lambda/cc)) ; a utility used at run time to dispatch a call with or without ; the continuation argument, depending on the function @@ -26,7 +26,7 @@ (apply f (cons k args)) (k (apply f args)))) (define *funcall/cc-names* - (list-to-vector + (list->vector (map (lambda (i) (intern (string 'funcall/cc- i))) (iota 6)))) (define-macro (def-funcall/cc-n args) diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index c2901d0..46310e4 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -153,7 +153,7 @@ void lerror(value_t e, char *format, ...) __attribute__ ((__noreturn__)); void raise(value_t e) __attribute__ ((__noreturn__)); void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__)); void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__)); -extern value_t ArgError, IOError, KeyError; +extern value_t ArgError, IOError, KeyError, MemoryError; static inline void argcount(char *fname, uint32_t nargs, uint32_t c) { if (__unlikely(nargs != c)) @@ -220,7 +220,7 @@ typedef struct { #define cv_isstr(cv) (cv_class(cv)->eltype == bytetype) #define cvalue_data(v) cv_data((cvalue_t*)ptr(v)) -#define value2c(type, v) (type)cv_data((cvalue_t*)ptr(v)) +#define value2c(type, v) ((type)cv_data((cvalue_t*)ptr(v))) #define valid_numtype(v) ((v) < N_NUMTYPES) #define cp_class(cp) ((cp)->type) diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c index 468bc30..6bb5d0f 100644 --- a/femtolisp/iostream.c +++ b/femtolisp/iostream.c @@ -7,7 +7,8 @@ #include "llt.h" #include "flisp.h" -static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym, instrsym; +static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym; +static value_t instrsym, outstrsym; static fltype_t *iostreamtype; void print_iostream(value_t v, ios_t *f, int princ) @@ -60,13 +61,15 @@ value_t fl_file(value_t *args, uint32_t nargs) { if (nargs < 1) argcount("file", nargs, 1); - int i, r=1, w=0, c=0, t=0, a=0; + int i, r=0, w=0, c=0, t=0, a=0; for(i=1; i < (int)nargs; i++) { if (args[i] == wrsym) w = 1; - else if (args[i] == apsym) a = 1; - else if (args[i] == crsym) c = 1; - else if (args[i] == truncsym) t = 1; + else if (args[i] == apsym) { a = 1; w = 1; } + else if (args[i] == crsym) { c = 1; w = 1; } + else if (args[i] == truncsym) { t = 1; w = 1; } + else if (args[i] == rdsym) r = 1; } + if ((r|w|c|t|a) == 0) r = 1; // default to reading value_t f = cvalue(iostreamtype, sizeof(ios_t)); char *fname = tostring(args[0], "file"); ios_t *s = value2c(ios_t*, f); @@ -76,6 +79,17 @@ value_t fl_file(value_t *args, uint32_t nargs) return f; } +value_t fl_memstream(value_t *args, u_int32_t nargs) +{ + argcount("memstream", nargs, 0); + (void)args; + value_t f = cvalue(iostreamtype, sizeof(ios_t)); + ios_t *s = value2c(ios_t*, f); + if (ios_mem(s, 0) == NULL) + lerror(MemoryError, "memstream: could not allocate stream"); + return f; +} + value_t fl_read(value_t *args, u_int32_t nargs) { if (nargs > 1) { @@ -152,9 +166,84 @@ value_t fl_ioprinc(value_t *args, u_int32_t nargs) return args[nargs-1]; } +value_t fl_ioread(value_t *args, u_int32_t nargs) +{ + if (nargs != 3) + argcount("io.read", nargs, 2); + (void)toiostream(args[0], "io.read"); + size_t n; + fltype_t *ft; + if (nargs == 3) { + // form (io.read s type count) + ft = get_array_type(args[1]); + n = toulong(args[2], "io.read") * ft->elsz; + } + else { + ft = get_type(args[1]); + if (ft->eltype != NULL && !iscons(cdr_(cdr_(args[1])))) + lerror(ArgError, "io.read: incomplete type"); + n = ft->size; + } + value_t cv = cvalue(ft, n); + char *data; + if (iscvalue(cv)) data = cv_data((cvalue_t*)ptr(cv)); + else data = cp_data((cprim_t*)ptr(cv)); + size_t got = ios_read(value2c(ios_t*,args[0]), data, n); + if (got < n) + lerror(IOError, "io.read: end of input reached"); + return cv; +} + +// get pointer and size for any plain-old-data value +static void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz) +{ + if (isiostream(v) && (value2c(ios_t*,v)->bm == bm_mem)) { + ios_t *x = value2c(ios_t*,v); + *pdata = x->buf; + *psz = x->size; + } + else if (iscvalue(v)) { + cvalue_t *pcv = (cvalue_t*)ptr(v); + *pdata = cv_data(pcv); + *psz = cv_len(pcv); + } + else if (iscprim(v)) { + cprim_t *pcp = (cprim_t*)ptr(v); + *pdata = cp_data(pcp); + *psz = cp_class(pcp)->size; + } + else { + type_error(fname, "byte stream", v); + } +} + +value_t fl_iowrite(value_t *args, u_int32_t nargs) +{ + argcount("io.write", nargs, 2); + ios_t *s = toiostream(args[0], "io.write"); + char *data; + size_t sz; + to_sized_ptr(args[1], "io.write", &data, &sz); + size_t n = ios_write(s, data, sz); + return size_wrap(n); +} + +value_t fl_dump(value_t *args, u_int32_t nargs) +{ + argcount("dump", nargs, 1); + ios_t *s = toiostream(symbol_value(outstrsym), "dump"); + char *data; + size_t sz; + to_sized_ptr(args[0], "dump", &data, &sz); + hexdump(s, data, sz, 0); + return FL_T; +} + static builtinspec_t iostreamfunc_info[] = { { "iostream?", fl_iostreamp }, + { "dump", fl_dump }, { "file", fl_file }, + { "memstream", fl_memstream }, { "read", fl_read }, { "io.print", fl_ioprint }, { "io.princ", fl_ioprinc }, @@ -163,6 +252,8 @@ static builtinspec_t iostreamfunc_info[] = { { "io.eof?" , fl_ioeof }, { "io.getc" , fl_iogetc }, { "io.discardbuffer", fl_iopurge }, + { "io.read", fl_ioread }, + { "io.write", fl_iowrite }, { NULL, NULL } }; @@ -175,6 +266,7 @@ void iostream_init() crsym = symbol(":create"); truncsym = symbol(":truncate"); instrsym = symbol("*input-stream*"); + outstrsym = symbol("*output-stream*"); iostreamtype = define_opaque_type(iostreamsym, sizeof(ios_t), &iostream_vtable, NULL); assign_global_builtins(iostreamfunc_info); diff --git a/femtolisp/printcases.lsp b/femtolisp/printcases.lsp index 92b5d0a..702e11f 100644 --- a/femtolisp/printcases.lsp +++ b/femtolisp/printcases.lsp @@ -7,7 +7,7 @@ bq-process (map-int (lambda (x) `(a b c d e)) 90) -(list-to-vector (map-int (lambda (x) `(a b c d e)) 90)) +(list->vector (map-int (lambda (x) `(a b c d e)) 90)) '((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y)) diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 0aeab28..3549ea9 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -6,11 +6,7 @@ (if (not (bound? 'eq)) (begin (set-constant! 'eq eq?) - (set-constant! 'eqv eqv?) - (set-constant! 'equal equal?) - (set-constant! 'rplaca set-car!) - (set-constant! 'rplacd set-cdr!) - (set-constant! 'char? (lambda (x) (eq? (typeof x) 'wchar))))) + (set-constant! 'equal equal?))) ; convert a sequence of body statements to a single expression. ; this allows define, defun, defmacro, let, etc. to contain multiple @@ -69,8 +65,8 @@ ((null? (cdr lsts)) (car lsts)) ((null? (car lsts)) (apply nconc (cdr lsts))) (#t (prog1 (car lsts) - (rplacd (last (car lsts)) - (apply nconc (cdr lsts))))))) + (set-cdr! (last (car lsts)) + (apply nconc (cdr lsts))))))) (define (append . lsts) (cond ((null? lsts) ()) @@ -83,24 +79,24 @@ (define (member item lst) (cond ((atom? lst) #f) - ((equal (car lst) item) lst) + ((equal? (car lst) item) lst) (#t (member item (cdr lst))))) (define (memq item lst) (cond ((atom? lst) #f) - ((eq (car lst) item) lst) + ((eq? (car lst) item) lst) (#t (memq item (cdr lst))))) (define (memv item lst) (cond ((atom? lst) #f) - ((eqv (car lst) item) lst) + ((eqv? (car lst) item) lst) (#t (memv item (cdr lst))))) (define (assoc item lst) (cond ((atom? lst) #f) - ((equal (caar lst) item) (car lst)) + ((equal? (caar lst) item) (car lst)) (#t (assoc item (cdr lst))))) (define (assv item lst) (cond ((atom? lst) #f) - ((eqv (caar lst) item) (car lst)) + ((eqv? (caar lst) item) (car lst)) (#t (assv item (cdr lst))))) (define (macrocall? e) (and (symbol? (car e)) @@ -192,9 +188,9 @@ (define (expand x) (macroexpand x)) -(define = eqv) -(define eql eqv) -(define (/= a b) (not (eqv a b))) +(define = eqv?) +(define eql eqv?) +(define (/= a b) (not (eqv? a b))) (define != /=) (define (> a b) (< b a)) (define (<= a b) (not (< b a))) @@ -205,6 +201,7 @@ (define remainder mod) (define (abs x) (if (< x 0) (- x) x)) (define (identity x) x) +(define (char? x) (eq? (typeof x) 'wchar)) (define K prog1) ; K combinator ;) (define begin0 prog1) @@ -250,7 +247,7 @@ (define (nlist* . l) (if (atom? (cdr l)) (car l) - (rplacd l (apply nlist* (cdr l))))) + (set-cdr! l (apply nlist* (cdr l))))) (define (lastcdr l) (if (atom? l) l @@ -265,7 +262,7 @@ (define (map! f lst) (prog1 lst (while (pair? lst) - (rplaca lst (f (car lst))) + (set-car! lst (f (car lst))) (set! lst (cdr lst))))) (define (mapcar f . lsts) @@ -318,8 +315,8 @@ (let ((prev ())) (while (pair? l) (set! l (prog1 (cdr l) - (rplacd l (prog1 prev - (set! prev l)))))) + (set-cdr! l (prog1 prev + (set! prev l)))))) prev)) (define-macro (let* binds . body) @@ -336,8 +333,8 @@ (define (revappend l1 l2) (nconc (reverse l1) l2)) (define (nreconc l1 l2) (nconc (nreverse l1) l2)) -(define (list-to-vector l) (apply vector l)) -(define (vector-to-list v) +(define (list->vector l) (apply vector l)) +(define (vector->list v) (let ((n (length v)) (l ())) (for 1 n @@ -362,7 +359,7 @@ (define (bq-process x) (cond ((self-evaluating? x) (if (vector? x) - (let ((body (bq-process (vector-to-list x)))) + (let ((body (bq-process (vector->list x)))) (if (eq (car body) 'list) (cons vector (cdr body)) (list apply vector body))) @@ -408,7 +405,7 @@ (list 'quote v))) (define-macro (case key . clauses) - (define (vals-to-cond key v) + (define (vals->cond key v) (cond ((eq? v 'else) 'else) ((null? v) #f) ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v)))) @@ -416,7 +413,7 @@ (let ((g (gensym))) `(let ((,g ,key)) (cond ,@(map (lambda (clause) - (cons (vals-to-cond g (car clause)) + (cons (vals->cond g (car clause)) (cdr clause))) clauses))))) @@ -453,7 +450,7 @@ (set! acc first) (for 1 (- n 1) (lambda (i) - (begin (rplacd acc (cons (f i) ())) + (begin (set-cdr! acc (cons (f i) ())) (set! acc (cdr acc))))) first))) diff --git a/femtolisp/test.lsp b/femtolisp/test.lsp index 18b6cd5..2b65a85 100644 --- a/femtolisp/test.lsp +++ b/femtolisp/test.lsp @@ -68,7 +68,7 @@ (lambda (acc i n) (if (= i n) first - (begin (rplacd acc (cons (f i) ())) + (begin (set-cdr! acc (cons (f i) ())) (map-int- (cdr acc) (+ i 1) n))))) first 1 n)))) @@ -116,8 +116,8 @@ ; swap the cars and cdrs of every cons in a structure (define (swapad c) (if (atom? c) c - (rplacd c (K (swapad (car c)) - (rplaca c (swapad (cdr c))))))) + (set-cdr! c (K (swapad (car c)) + (set-car! c (swapad (cdr c))))))) (define (without x l) (filter (lambda (e) (not (eq e x))) l)) @@ -202,7 +202,7 @@ (set! ,first ,acc) (while ,cnd (begin (set! ,acc - (cdr (rplacd ,acc (cons ,what ())))) + (cdr (set-cdr! ,acc (cons ,what ())))) ,@body)) (cdr ,first)))) @@ -215,7 +215,7 @@ (for ,lo ,hi (lambda (,var) (begin (set! ,acc - (cdr (rplacd ,acc (cons ,what ())))) + (cdr (set-cdr! ,acc (cons ,what ())))) ,@body))) (cdr ,first)))) diff --git a/femtolisp/todo b/femtolisp/todo index 7979b82..a66ad5f 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -848,15 +848,15 @@ IOStream API *princ *file iostream - (stream[ cvalue-as-bytestream]) - memstream +*memstream fifo socket *io.eof *io.flush *io.close *io.discardbuffer - io.write - (io.write s cvalue) - io.read - (io.read s ctype [len]) +*io.write - (io.write s cvalue) +*io.read - (io.read s ctype [len]) io.getc - get utf8 character(s) io.readline io.copy - (io.copy to from [nbytes]) @@ -865,7 +865,7 @@ IOStream API io.seek - (io.seek s offset) io.seekend - move to end of stream io.trunc - io.tostring! - destructively convert stringstream to string + io.read! - destructively take data io.readlines io.readall print-to-string diff --git a/femtolisp/types.c b/femtolisp/types.c index a5660a9..bbaf762 100644 --- a/femtolisp/types.c +++ b/femtolisp/types.c @@ -41,6 +41,10 @@ fltype_t *get_type(value_t t) if (iscons(t)) { if (isarray) { fltype_t *eltype = get_type(car_(cdr_(t))); + if (eltype->size == 0) { + free(ft); + lerror(ArgError, "invalid array element type"); + } ft->elsz = eltype->size; ft->eltype = eltype; ft->init = &cvalue_array_init; diff --git a/llt/ios.c b/llt/ios.c index 7cd4e19..9ba9ff1 100644 --- a/llt/ios.c +++ b/llt/ios.c @@ -328,6 +328,7 @@ static void _write_update_pos(ios_t *s) size_t ios_write(ios_t *s, char *data, size_t n) { + if (s->readonly) return 0; if (n == 0) return 0; size_t space; size_t wrote = 0; @@ -566,7 +567,8 @@ int ios_setbuf(ios_t *s, char *buf, size_t size, int own) size_t nvalid=0; nvalid = (size < s->size) ? size : s->size; - memcpy(buf, s->buf, nvalid); + if (nvalid > 0) + memcpy(buf, s->buf, nvalid); if (s->bpos > nvalid) { // truncated s->bpos = nvalid; @@ -590,6 +592,14 @@ int ios_bufmode(ios_t *s, bufmode_t mode) return 0; } +void ios_set_readonly(ios_t *s) +{ + if (s->readonly) return; + ios_flush(s); + s->state = bst_none; + s->readonly = 1; +} + void ios_bswap(ios_t *s, int bswap) { s->byteswap = !!bswap; @@ -645,6 +655,8 @@ ios_t *ios_file(ios_t *s, char *fname, int rd, int wr, int create, int trunc) goto open_file_err; s = ios_fd(s, fd, 1); s->ownfd = 1; + if (!wr) + s->readonly = 1; return s; open_file_err: s->fd = -1; diff --git a/llt/ios.h b/llt/ios.h index edf4b31..3eb1e01 100644 --- a/llt/ios.h +++ b/llt/ios.h @@ -38,7 +38,7 @@ typedef struct { long fd; unsigned char byteswap:1; - //unsigned char readonly:1; + unsigned char readonly:1; unsigned char ownbuf:1; unsigned char ownfd:1; unsigned char _eof:1; @@ -76,6 +76,7 @@ char *ios_takebuf(ios_t *s, size_t *psize); // release buffer to caller // set buffer space to use int ios_setbuf(ios_t *s, char *buf, size_t size, int own); int ios_bufmode(ios_t *s, bufmode_t mode); +void ios_set_readonly(ios_t *s); void ios_bswap(ios_t *s, int bswap); int ios_copy(ios_t *to, ios_t *from, size_t nbytes); int ios_copyall(ios_t *to, ios_t *from);