diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index e41874d..867ab23 100644 --- 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,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) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 46c7539..0703125 100644 --- a/femtolisp/cvalues.c +++ b/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,31 +245,45 @@ static void cv_pin(cvalue_t *cv) } */ -#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 @@ value_t mk_##typenam(ctype##_t n) \ 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 @@ 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])) { - 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 @@ 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); - 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); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 46310e4..09bcd1c 100644 --- a/femtolisp/flisp.h +++ b/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, diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c index d38ad0b..85349c9 100644 --- a/femtolisp/iostream.c +++ b/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 } }; diff --git a/femtolisp/read.c b/femtolisp/read.c index 9507dc9..8cb086a 100644 --- a/femtolisp/read.c +++ b/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) diff --git a/femtolisp/string.c b/femtolisp/string.c index 8baf66b..4762e78 100644 --- 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 @@ 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])); diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 878438d..0ceda9e 100644 --- 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))) diff --git a/femtolisp/todo b/femtolisp/todo index 75beb59..244695c 100644 --- a/femtolisp/todo +++ b/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 diff --git a/llt/ios.c b/llt/ios.c index 9075c91..79b5289 100644 --- a/llt/ios.c +++ b/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) {