ref: fdfaacfbe55da150c6637288e821dd69780026e2
parent: 40cff81550d8ba5692868723c2c336916f768057
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Mar 4 22:48:17 EST 2009
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
--- a/femtolisp/cps.lsp
+++ b/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 args) 1)
+ (length= body 2)
+ (length= args 1)
(eq (car body) (car args))
(not (eq (cadr body) (car args)))
(symbol? (cadr body)))))
@@ -227,7 +227,7 @@
; ((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)))
@@ -234,7 +234,7 @@
(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)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -206,14 +206,18 @@
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,31 +245,45 @@
}
*/
-#define num_ctor(typenam, ctype, cnvt, tag) \
-static void cvalue_##typenam##_init(fltype_t *type, value_t arg, \
- void *dest) \
-{ \- ctype##_t n=0; \
- (void)type; \
- if (isfixnum(arg)) { \- n = numval(arg); \
- } \
- else if (iscprim(arg)) { \- cprim_t *cp = (cprim_t*)ptr(arg); \
- void *p = cp_data(cp); \
- n = (ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \
- } \
- else { \- type_error(#typenam, "number", arg); \
- } \
- *((ctype##_t*)dest) = n; \
-} \
+#define num_init(ctype, cnvt, tag) \
+static int cvalue_##ctype##_init(fltype_t *type, value_t arg, \
+ void *dest) \
+{ \+ ctype##_t n=0; \
+ (void)type; \
+ if (isfixnum(arg)) { \+ n = numval(arg); \
+ } \
+ else if (iscprim(arg)) { \+ cprim_t *cp = (cprim_t*)ptr(arg); \
+ void *p = cp_data(cp); \
+ n = (ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \
+ } \
+ else { \+ 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, \
- args[0], cp_data((cprim_t*)ptr(cp))); \
+ if (cvalue_##ctype##_init(typenam##type, \
+ 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 @@
return cp; \
}
-num_ctor(int8, int8, int32, T_INT8)
-num_ctor(uint8, uint8, uint32, T_UINT8)
-num_ctor(int16, int16, int32, T_INT16)
-num_ctor(uint16, uint16, uint32, T_UINT16)
-num_ctor(int32, int32, int32, T_INT32)
-num_ctor(uint32, uint32, uint32, T_UINT32)
-num_ctor(int64, int64, int64, T_INT64)
-num_ctor(uint64, uint64, uint64, T_UINT64)
-num_ctor(byte, uint8, uint32, T_UINT8)
-num_ctor(wchar, int32, int32, T_INT32)
+num_ctor(int8, int8, T_INT8)
+num_ctor(uint8, uint8, T_UINT8)
+num_ctor(int16, int16, T_INT16)
+num_ctor(uint16, uint16, T_UINT16)
+num_ctor(int32, int32, T_INT32)
+num_ctor(uint32, uint32, T_UINT32)
+num_ctor(int64, int64, T_INT64)
+num_ctor(uint64, uint64, T_UINT64)
+num_ctor(byte, uint8, T_UINT8)
+num_ctor(wchar, int32, T_INT32)
#ifdef BITS64
-num_ctor(long, long, int64, T_INT64)
-num_ctor(ulong, ulong, uint64, T_UINT64)
+num_ctor(long, int64, T_INT64)
+num_ctor(ulong, uint64, T_UINT64)
#else
-num_ctor(long, long, int32, T_INT32)
-num_ctor(ulong, ulong, uint32, T_UINT32)
+num_ctor(long, int32, T_INT32)
+num_ctor(ulong, uint32, T_UINT32)
#endif
-num_ctor(float, float, double, T_FLOAT)
-num_ctor(double, double, double, T_DOUBLE)
+num_ctor(float, float, T_FLOAT)
+num_ctor(double, double, T_DOUBLE)
value_t size_wrap(size_t sz)
{@@ -315,7 +333,7 @@
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 @@
while (iscons(syms)) { if (car_(syms) == arg) {*(int*)dest = n;
- return;
+ return 0;
}
n++;
syms = cdr_(syms);
@@ -348,6 +366,7 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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])) {- cvalue_t *cv = (cvalue_t*)ptr(args[0]);
- return size_wrap(cv_len(cv));
+ if (issymbol(args[0]) || iscons(args[0])) {+ int a;
+ return size_wrap(ctype_sizeof(args[0], &a));
}
- 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 @@
#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 @@
mk_primtype(uint32);
mk_primtype(int64);
mk_primtype(uint64);
- mk_primtype(long);
- mk_primtype(ulong);
- mk_primtype(byte);
- mk_primtype(wchar);
+#ifdef BITS64
+ mk_primtype_(long,int64);
+ mk_primtype_(ulong,uint64);
+#else
+ mk_primtype_(long,int32);
+ mk_primtype_(ulong,uint32);
+#endif
+ mk_primtype_(byte,uint8);
+ mk_primtype_(wchar,int32);
mk_primtype(float);
mk_primtype(double);
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -174,7 +174,7 @@
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,9 +268,13 @@
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);
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -79,14 +79,14 @@
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 @@
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 @@
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 @@
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 @@
{ "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 }};
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -580,7 +580,7 @@
case TOK_DOUBLEQUOTE:
return read_string();
}
- return NIL;
+ return FL_F;
}
value_t read_sexpr(value_t f)
--- a/femtolisp/string.c
+++ b/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;
- ios_mem(&str, 0);
- print(&str, v, princ);
- value_t outp;
- if (str.size < MAX_INL_SIZE) {- outp = cvalue_string(str.size);
- memcpy(cv_data((cvalue_t*)ptr(outp)), str.buf, str.size);
- }
- 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);
+ PUSH(v);
+ value_t buf = fl_buffer(NULL, 0);
+ ios_t *s = value2c(ios_t*,buf);
+ print(s, Stack[SP-1], princ);
+ Stack[SP-1] = buf;
+ value_t outp = stream_to_string(&Stack[SP-1]);
+ (void)POP();
return outp;
}
@@ -93,7 +86,7 @@
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 @@
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]));
--- a/femtolisp/system.lsp
+++ b/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))
- (io.princ *stderr* "type-error: ")
- (io.print *stderr* (cadr e))
- (io.princ *stderr* ": expected ")
- (io.print *stderr* (caddr e))
- (io.princ *stderr* ", got ")
+ (length= e 4))
+ (io.princ *stderr*
+ "type-error: " (cadr e) ": expected " (caddr e) ", 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))
- (io.print *stderr* (car e))
- (io.princ *stderr* ": " (cadr e)))
+ (length= e 2))
+ (io.princ *stderr* (car 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)))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -838,7 +838,7 @@
*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 @@
*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 @@
io.seekend - move to end of stream
io.trunc
io.read! - destructively take data
+*io.tostring!
io.readlines
io.readall
print-to-string
@@ -954,6 +956,8 @@
* make raising a memory error non-consing
- 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
--- a/llt/ios.c
+++ b/llt/ios.c
@@ -674,6 +674,7 @@
s->ownfd = 0;
s->_eof = 0;
s->rereadable = 0;
+ s->readonly = 0;
}
/* stream object initializers. we do no allocation. */
@@ -826,6 +827,13 @@
*pwc = u8_nextchar(s->buf, &i);
ios_read(s, buf, sz+1);
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)