adding dump, memstream, io.read, and io.write

more renaming
allowing iostreams to be read-only
fixing bug allowing arrays with 0-size elements

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)

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)

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] == apsym)    { a = 1; w = 1; }
-        else if (args[i] == crsym)    c = 1;
+        else if (args[i] == crsym)    { c = 1; w = 1; }
-        else if (args[i] == truncsym) t = 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);

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))
 

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! 'equal    equal?)
-      (set-constant! 'rplaca   set-car!)
-      (set-constant! 'rplacd   set-cdr!)
-      (set-constant! 'char?    (lambda (x) (eq? (typeof x) 'wchar)))))
 
 ; 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))
+		   (set-cdr! (last (car lsts))
-			   (apply nconc (cdr 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 =   eqv?)
-(define eql eqv)
+(define eql eqv?)
-(define (/= a b) (not (eqv a b)))
+(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-cdr! l (prog1 prev
-					   (set! prev l))))))
+					     (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 (list->vector l) (apply vector l))
-(define (vector-to-list v)
+(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)))
 

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))
+      (set-cdr! c (K (swapad (car c))
-		   (rplaca c (swapad (cdr 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))))
 

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.write     - (io.write s cvalue)
- io.read      - (io.read s ctype [len])
+*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

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;

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;

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);