ref: 2cf5187ca998708d1b55f13cc9b4c22a5362f8d0
parent: 923c7d5495a4251bea0e620ec6fcf17d0d0725d1
author: JeffBezanson <[email protected]>
date: Sun Mar 1 23:26:16 EST 2009
adding dump, memstream, io.read, and io.write more renaming allowing iostreams to be read-only fixing bug allowing arrays with 0-size elements
--- 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)
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -153,7 +153,7 @@
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 @@
#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)
--- 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 @@
{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 @@
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 @@
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 @@
{ "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 @@
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);
--- a/femtolisp/printcases.lsp
+++ b/femtolisp/printcases.lsp
@@ -7,7 +7,7 @@
(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))
--- 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)))
--- 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))))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -848,7 +848,7 @@
*princ
*file
iostream - (stream[ cvalue-as-bytestream])
- memstream
+*memstream
fifo
socket
*io.eof
@@ -855,8 +855,8 @@
*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 @@
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
--- a/femtolisp/types.c
+++ b/femtolisp/types.c
@@ -41,6 +41,10 @@
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;
--- a/llt/ios.c
+++ b/llt/ios.c
@@ -328,6 +328,7 @@
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 @@
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 @@
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 @@
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;
--- a/llt/ios.h
+++ b/llt/ios.h
@@ -38,7 +38,7 @@
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 @@
// 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);