adding io.putc, io.tostring!, string.map, print-to-string

fixing bug in ios, not initializing readonly flag
updating string and sizeof to use new strstream functions
removing some redundant numeric type init functions

femtolisp/cps.lsp

@@ -205,14 +205,14 @@
 
 (define (β-reduce- form)
         ; ((lambda (f) (f arg)) X) => (X arg)
-  (cond ((and (= (length form) 2)
+  (cond ((and (length= form 2)
               (pair? (car form))
               (eq (caar form) 'lambda)
               (let ((args (cadr (car form)))
                     (body (caddr (car form))))
                 (and (pair? body) (pair? args)
-                     (= (length body) 2)
+                     (length= body 2)
-                     (= (length args) 1)
+                     (length= args 1)
                      (eq (car body) (car args))
                      (not (eq (cadr body) (car args)))
                      (symbol? (cadr body)))))
@@ -227,14 +227,14 @@
         ; ((lambda (p1) ((lambda (args...) body) exprs...)) s) =>
         ; ((lambda (p1 args...) body) s exprs...)
         ; where exprs... doesn't contain p1
-        ((and (= (length form) 2)
+        ((and (length= form 2)
               (pair? (car form))
               (eq (caar form) 'lambda)
               (or (atom? (cadr form)) (constant? (cadr form)))
               (let ((args (cadr (car form)))
                     (s (cadr form))
                     (body (caddr (car form))))
-                (and (pair? args) (= (length args) 1)
+                (and (pair? args) (length= args 1)
                      (pair? body)
                      (pair? (car body))
                      (eq (caar body) 'lambda)

femtolisp/cvalues.c

@@ -206,14 +206,18 @@ value_t cvalue_static_cstring(char *str)
     return cvalue_from_ref(stringtype, str, strlen(str), NIL);
 }
 
-value_t string_from_cstr(char *str)
+value_t string_from_cstrn(char *str, size_t n)
 {
-    size_t n = strlen(str);
     value_t v = cvalue_string(n);
     memcpy(cvalue_data(v), str, n);
     return v;
 }
 
+value_t string_from_cstr(char *str)
+{
+    return string_from_cstrn(str, strlen(str));
+}
+
 int isstring(value_t v)
 {
     return (iscvalue(v) && cv_isstr((cvalue_t*)ptr(v)));
@@ -241,8 +245,8 @@ static void cv_pin(cvalue_t *cv)
 }
 */
 
-#define num_ctor(typenam, ctype, cnvt, tag)                             \
+#define num_init(ctype, cnvt, tag)                              \
-static void cvalue_##typenam##_init(fltype_t *type, value_t arg,        \
+static int cvalue_##ctype##_init(fltype_t *type, value_t arg,   \
                                  void *dest)                    \
 {                                                               \
     ctype##_t n=0;                                              \
@@ -256,16 +260,30 @@ static void cvalue_##typenam##_init(fltype_t *type, value_t arg,        \
         n = (ctype##_t)conv_to_##cnvt(p, cp_numtype(cp));       \
     }                                                           \
     else {                                                      \
-        type_error(#typenam, "number", arg);                            \
+        return 1;                                               \
     }                                                           \
     *((ctype##_t*)dest) = n;                                    \
-}                                                                       \
+    return 0;                                                   \
+}
+num_init(int8, int32, T_INT8)
+num_init(uint8, uint32, T_UINT8)
+num_init(int16, int32, T_INT16)
+num_init(uint16, uint32, T_UINT16)
+num_init(int32, int32, T_INT32)
+num_init(uint32, uint32, T_UINT32)
+num_init(int64, int64, T_INT64)
+num_init(uint64, uint64, T_UINT64)
+num_init(float, double, T_FLOAT)
+num_init(double, double, T_DOUBLE)
+
+#define num_ctor(typenam, ctype, tag)                                   \
 value_t cvalue_##typenam(value_t *args, u_int32_t nargs)                \
 {                                                                       \
     if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; }             \
     value_t cp = cprim(typenam##type, sizeof(ctype##_t));               \
-    cvalue_##typenam##_init(typenam##type,                              \
+    if (cvalue_##ctype##_init(typenam##type,                            \
-                            args[0], cp_data((cprim_t*)ptr(cp)));       \
+                              args[0], cp_data((cprim_t*)ptr(cp))))     \
+        type_error(#typenam, "number", args[0]);                        \
     return cp;                                                          \
 }                                                                       \
 value_t mk_##typenam(ctype##_t n)                                       \
@@ -275,25 +293,25 @@ value_t mk_##typenam(ctype##_t n)                                       \
     return cp;                                                          \
 }
 
-num_ctor(int8, int8, int32, T_INT8)
+num_ctor(int8, int8, T_INT8)
-num_ctor(uint8, uint8, uint32, T_UINT8)
+num_ctor(uint8, uint8, T_UINT8)
-num_ctor(int16, int16, int32, T_INT16)
+num_ctor(int16, int16, T_INT16)
-num_ctor(uint16, uint16, uint32, T_UINT16)
+num_ctor(uint16, uint16, T_UINT16)
-num_ctor(int32, int32, int32, T_INT32)
+num_ctor(int32, int32, T_INT32)
-num_ctor(uint32, uint32, uint32, T_UINT32)
+num_ctor(uint32, uint32, T_UINT32)
-num_ctor(int64, int64, int64, T_INT64)
+num_ctor(int64, int64, T_INT64)
-num_ctor(uint64, uint64, uint64, T_UINT64)
+num_ctor(uint64, uint64, T_UINT64)
-num_ctor(byte,  uint8, uint32, T_UINT8)
+num_ctor(byte,  uint8, T_UINT8)
-num_ctor(wchar, int32, int32, T_INT32)
+num_ctor(wchar, int32, T_INT32)
 #ifdef BITS64
-num_ctor(long, long, int64, T_INT64)
+num_ctor(long, int64, T_INT64)
-num_ctor(ulong, ulong, uint64, T_UINT64)
+num_ctor(ulong, uint64, T_UINT64)
 #else
-num_ctor(long, long, int32, T_INT32)
+num_ctor(long, int32, T_INT32)
-num_ctor(ulong, ulong, uint32, T_UINT32)
+num_ctor(ulong, uint32, T_UINT32)
 #endif
-num_ctor(float, float, double, T_FLOAT)
+num_ctor(float, float, T_FLOAT)
-num_ctor(double, double, double, T_DOUBLE)
+num_ctor(double, double, T_DOUBLE)
 
 value_t size_wrap(size_t sz)
 {
@@ -315,7 +333,7 @@ size_t toulong(value_t n, char *fname)
     return 0;
 }
 
-static void cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
+static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
 {
     int n=0;
     value_t syms;
@@ -328,7 +346,7 @@ static void cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
         while (iscons(syms)) {
             if (car_(syms) == arg) {
                 *(int*)dest = n;
-                return;
+                return 0;
             }
             n++;
             syms = cdr_(syms);
@@ -348,6 +366,7 @@ static void cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
     if ((unsigned)n >= llength(syms))
         lerror(ArgError, "enum: value out of range");
     *(int*)dest = n;
+    return 0;
 }
 
 value_t cvalue_enum(value_t *args, u_int32_t nargs)
@@ -388,7 +407,7 @@ static size_t predict_arraylen(value_t arg)
     return 1;
 }
 
-static void cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
+static int cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
 {
     value_t type = ft->type;
     size_t elsize, i, cnt, sz;
@@ -408,7 +427,7 @@ static void cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
     if (isvector(arg)) {
         array_init_fromargs((char*)dest, &vector_elt(arg,0), cnt,
                             eltype, elsize);
-        return;
+        return 0;
     }
     else if (iscons(arg) || arg==NIL) {
         i = 0;
@@ -423,7 +442,7 @@ static void cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
             lerror(ArgError, "array: size mismatch");
         array_init_fromargs((char*)dest, &Stack[SP-i], i, eltype, elsize);
         POPN(i);
-        return;
+        return 0;
     }
     else if (iscvalue(arg)) {
         cvalue_t *cv = (cvalue_t*)ptr(arg);
@@ -434,7 +453,7 @@ static void cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
                     memcpy(dest, cv_data(cv), sz);
                 else
                     lerror(ArgError, "array: size mismatch");
-                return;
+                return 0;
             }
             else {
                 // TODO: initialize array from different type elements
@@ -446,6 +465,7 @@ static void cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
         cvalue_init(eltype, arg, dest);
     else
         type_error("array", "sequence", arg);
+    return 0;
 }
 
 value_t cvalue_array(value_t *args, u_int32_t nargs)
@@ -593,19 +613,39 @@ size_t ctype_sizeof(value_t type, int *palign)
     return 0;
 }
 
+// get pointer and size for any plain-old-data value
+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, "bytes", v);
+    }
+}
+
 value_t cvalue_sizeof(value_t *args, u_int32_t nargs)
 {
     argcount("sizeof", nargs, 1);
-    if (iscvalue(args[0])) {
+    if (issymbol(args[0]) || iscons(args[0])) {
-        cvalue_t *cv = (cvalue_t*)ptr(args[0]);
-        return size_wrap(cv_len(cv));
-    }
-    else if (iscprim(args[0])) {
-        cprim_t *cp = (cprim_t*)ptr(args[0]);
-        return fixnum(cp_class(cp)->size);
-    }
         int a;
         return size_wrap(ctype_sizeof(args[0], &a));
+    }
+    size_t n; char *data;
+    to_sized_ptr(args[0], "sizeof", &data, &n);
+    return size_wrap(n);
 }
 
 value_t cvalue_typeof(value_t *args, u_int32_t nargs)
@@ -861,6 +901,9 @@ static builtinspec_t cvalues_builtin_info[] = {
 #define mk_primtype(name) \
   name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init
 
+#define mk_primtype_(name,ctype) \
+  name##type=get_type(name##sym);name##type->init = &cvalue_##ctype##_init
+
 void cvalues_init()
 {
     htable_new(&TypeTable, 256);
@@ -915,10 +958,15 @@ void cvalues_init()
     mk_primtype(uint32);
     mk_primtype(int64);
     mk_primtype(uint64);
-    mk_primtype(long);
+#ifdef BITS64
-    mk_primtype(ulong);
+    mk_primtype_(long,int64);
-    mk_primtype(byte);
+    mk_primtype_(ulong,uint64);
-    mk_primtype(wchar);
+#else
+    mk_primtype_(long,int32);
+    mk_primtype_(ulong,uint32);
+#endif
+    mk_primtype_(byte,uint8);
+    mk_primtype_(wchar,int32);
     mk_primtype(float);
     mk_primtype(double);
 

femtolisp/flisp.h

@@ -174,7 +174,7 @@ void fl_print_chr(char c, ios_t *f);
 void fl_print_str(char *s, ios_t *f);
 void fl_print_child(ios_t *f, value_t v, int princ);
 
-typedef void (*cvinitfunc_t)(struct _fltype_t*, value_t, void*);
+typedef int (*cvinitfunc_t)(struct _fltype_t*, value_t, void*);
 
 typedef struct _fltype_t {
     value_t type;
@@ -268,10 +268,14 @@ size_t toulong(value_t n, char *fname);
 value_t cvalue_string(size_t sz);
 value_t cvalue_static_cstring(char *str);
 value_t string_from_cstr(char *str);
+value_t string_from_cstrn(char *str, size_t n);
 int isstring(value_t v);
 int isnumber(value_t v);
+int isiostream(value_t v);
 value_t cvalue_compare(value_t a, value_t b);
 
+void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz);
+
 fltype_t *get_type(value_t t);
 fltype_t *get_array_type(value_t eltype);
 fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,

femtolisp/iostream.c

@@ -79,14 +79,14 @@ value_t fl_file(value_t *args, uint32_t nargs)
     return f;
 }
 
-value_t fl_memstream(value_t *args, u_int32_t nargs)
+value_t fl_buffer(value_t *args, u_int32_t nargs)
 {
-    argcount("memstream", nargs, 0);
+    argcount("buffer", 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");
+        lerror(MemoryError, "buffer: could not allocate stream");
     return f;
 }
 
@@ -113,6 +113,17 @@ value_t fl_iogetc(value_t *args, u_int32_t nargs)
     return mk_wchar(wc);
 }
 
+value_t fl_ioputc(value_t *args, u_int32_t nargs)
+{
+    argcount("io.putc", nargs, 2);
+    ios_t *s = toiostream(args[0], "io.putc");
+    uint32_t wc;
+    if (!iscprim(args[1]) || ((cprim_t*)ptr(args[1]))->type != wchartype)
+        type_error("io.putc", "wchar", args[1]);
+    wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
+    return fixnum(ios_pututf8(s, wc));
+}
+
 value_t fl_ioflush(value_t *args, u_int32_t nargs)
 {
     argcount("io.flush", nargs, 1);
@@ -194,29 +205,6 @@ value_t fl_ioread(value_t *args, u_int32_t nargs)
     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);
@@ -263,11 +251,39 @@ value_t fl_ioreaduntil(value_t *args, u_int32_t nargs)
     return str;
 }
 
+value_t stream_to_string(value_t *ps)
+{
+    value_t str;
+    size_t n;
+    ios_t *st = value2c(ios_t*,*ps);
+    if (st->buf == &st->local[0]) {
+        n = st->size;
+        str = cvalue_string(n);
+        memcpy(cvalue_data(str), value2c(ios_t*,*ps)->buf, n);
+    }
+    else {
+        char *b = ios_takebuf(st, &n); n--;
+        b[n] = '\0';
+        str = cvalue_from_ref(stringtype, b, n, NIL);
+        cv_autorelease((cvalue_t*)ptr(str));
+    }
+    return str;
+}
+
+value_t fl_iotostring(value_t *args, u_int32_t nargs)
+{
+    argcount("io.tostring!", nargs, 1);
+    ios_t *src = toiostream(args[0], "io.tostring!");
+    if (src->bm != bm_mem)
+        lerror(ArgError, "io.tostring!: requires memory stream");
+    return stream_to_string(&args[0]);
+}
+
 static builtinspec_t iostreamfunc_info[] = {
     { "iostream?", fl_iostreamp },
     { "dump", fl_dump },
     { "file", fl_file },
-    { "memstream", fl_memstream },
+    { "buffer", fl_buffer },
     { "read", fl_read },
     { "io.print", fl_ioprint },
     { "io.princ", fl_ioprinc },
@@ -275,10 +291,12 @@ static builtinspec_t iostreamfunc_info[] = {
     { "io.close", fl_ioclose },
     { "io.eof?" , fl_ioeof },
     { "io.getc" , fl_iogetc },
+    { "io.putc" , fl_ioputc },
     { "io.discardbuffer", fl_iopurge },
     { "io.read", fl_ioread },
     { "io.write", fl_iowrite },
     { "io.readuntil", fl_ioreaduntil },
+    { "io.tostring!", fl_iotostring },
     { NULL, NULL }
 };
 

femtolisp/read.c

@@ -580,7 +580,7 @@ static value_t do_read_sexpr(value_t label)
     case TOK_DOUBLEQUOTE:
         return read_string();
     }
-    return NIL;
+    return FL_F;
 }
 
 value_t read_sexpr(value_t f)

femtolisp/string.c

@@ -14,24 +14,17 @@
 #include "llt.h"
 #include "flisp.h"
 
+extern value_t fl_buffer(value_t *args, u_int32_t nargs);
+extern value_t stream_to_string(value_t *ps);
 static value_t print_to_string(value_t v, int princ)
 {
-    ios_t str;
+    PUSH(v);
-    ios_mem(&str, 0);
+    value_t buf = fl_buffer(NULL, 0);
-    print(&str, v, princ);
+    ios_t *s = value2c(ios_t*,buf);
-    value_t outp;
+    print(s, Stack[SP-1], princ);
-    if (str.size < MAX_INL_SIZE) {
+    Stack[SP-1] = buf;
-        outp = cvalue_string(str.size);
+    value_t outp = stream_to_string(&Stack[SP-1]);
-        memcpy(cv_data((cvalue_t*)ptr(outp)), str.buf, str.size);
+    (void)POP();
-    }
-    else {
-        size_t sz;
-        char *buf = ios_takebuf(&str, &sz);
-        buf[sz] = '\0';
-        outp = cvalue_from_ref(stringtype, buf, sz-1, NIL);
-        cv_autorelease((cvalue_t*)ptr(outp));
-    }
-    ios_close(&str);
     return outp;
 }
 
@@ -93,7 +86,7 @@ value_t fl_string_encode(value_t *args, u_int32_t nargs)
             return str;
         }
     }
-    type_error("string.encode", "wide character array", args[0]);
+    type_error("string.encode", "wchar array", args[0]);
 }
 
 value_t fl_string_decode(value_t *args, u_int32_t nargs)
@@ -153,7 +146,7 @@ value_t fl_string(value_t *args, u_int32_t nargs)
             sz += cv_len((cvalue_t*)ptr(cv));
             continue;
         }
-        args[i] = print_to_string(args[i], 0);
+        args[i] = print_to_string(args[i], iscprim(args[i]));
         if (nargs == 1)  // convert single value to string
             return args[i];
         sz += cv_len((cvalue_t*)ptr(args[i]));

femtolisp/system.lsp

@@ -239,6 +239,15 @@
 (define (list-ref lst n)
   (car (nthcdr lst n)))
 
+; bounded length test
+; use this instead of (= (length lst) n), since it avoids unnecessary
+; work and always terminates.
+(define (length= lst n)
+  (cond ((< n 0)     #f)
+	((= n 0)     (null? lst))
+	((null? lst) (= n 0))
+	(else        (length= (cdr lst) (- n 1)))))
+
 (define (list* . l)
   (if (atom? (cdr l))
       (car l)
@@ -408,6 +417,7 @@
   (define (vals->cond key v)
     (cond ((eq? v 'else)   'else)
 	  ((null? v)       #f)
+          ((atom? v)       `(eqv? ,key ,v))
 	  ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
 	  (else            `(memv ,key ',v))))
   (let ((g (gensym)))
@@ -560,6 +570,20 @@
 		(trim-start s at-start 0 L)
 		(trim-end   s at-end   L))))
 
+(define (string.map f s)
+  (let ((b (buffer))
+	(n (length s)))
+    (let loop ((i 0))
+      (if (< i n)
+	  (begin (io.putc b (f (string.char s i)))
+		 (loop (string.inc s i)))
+	  (io.tostring! b)))))
+
+(define (print-to-string v)
+  (let ((b (buffer)))
+    (io.print b v)
+    (io.tostring! b)))
+
 (define (io.readline s) (io.readuntil s #byte(0xA)))
 
 (define (repl)
@@ -584,12 +608,9 @@
 (define (print-exception e)
   (cond ((and (pair? e)
 	      (eq? (car e) 'type-error)
-	      (= (length e) 4))
+	      (length= e 4))
-	 (io.princ *stderr* "type-error: ")
+	 (io.princ *stderr*
-	 (io.print *stderr* (cadr e))
+		   "type-error: " (cadr e) ": expected " (caddr e) ", got ")
-	 (io.princ *stderr* ": expected ")
-	 (io.print *stderr* (caddr e))
-	 (io.princ *stderr* ", got ")
 	 (io.print *stderr* (cadddr e)))
 
 	((and (pair? e)
@@ -610,9 +631,12 @@
 	 (io.princ *stderr* "in file " (cadr e)))
 
 	((and (list? e)
-	      (= (length e) 2))
+	      (length= e 2))
-	 (io.print *stderr* (car e))
+	 (io.princ *stderr* (car e) ": ")
-	 (io.princ *stderr* ": " (cadr e)))
+	 (let ((msg (cadr e)))
+	   ((if (or (string? msg) (symbol? msg))
+		io.princ io.print)
+	    *stderr* msg)))
 
 	(else (io.princ *stderr* "*** Unhandled exception: ")
 	      (io.print *stderr* e)))

femtolisp/todo

@@ -838,7 +838,7 @@ String API
 *string.encode  - to utf8
 *string.decode  - from utf8 to UCS
  string.width   - # columns
- string.map     - (string.map f s)
+*string.map     - (string.map f s)
 
 
 IOStream API
@@ -857,7 +857,8 @@ IOStream API
 *io.discardbuffer
 *io.write     - (io.write s cvalue)
 *io.read      - (io.read s ctype [len])
- io.getc      - get utf8 character(s)
+*io.getc      - get utf8 character
+*io.putc
 *io.readline
 *io.readuntil
  io.copy      - (io.copy to from [nbytes])
@@ -867,6 +868,7 @@ IOStream API
  io.seekend   - move to end of stream
  io.trunc
  io.read!     - destructively take data
+*io.tostring!
  io.readlines
  io.readall
  print-to-string
@@ -955,6 +957,8 @@ consolidated todo list as of 8/30:
 - eliminate string copy in lerror() when possible
 * fix printing lists of short strings
 
+- preallocate all byte,int8,uint8 values, and some wchars
+
 - remaining c types
 - remaining cvalues functions
 - finish ios

llt/ios.c

@@ -674,6 +674,7 @@ static void _ios_init(ios_t *s)
     s->ownfd = 0;
     s->_eof = 0;
     s->rereadable = 0;
+    s->readonly = 0;
 }
 
 /* stream object initializers. we do no allocation. */
@@ -828,6 +829,13 @@ int ios_getutf8(ios_t *s, uint32_t *pwc)
     return 1;
 }
 
+int ios_pututf8(ios_t *s, uint32_t wc)
+{
+    char buf[8];
+    size_t n = u8_toutf8(buf, 8, &wc, 1);
+    return ios_write(s, buf, n);
+}
+
 void ios_purge(ios_t *s)
 {
     if (s->state == bst_rd) {