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
This commit is contained in:
JeffBezanson 2009-03-05 03:48:17 +00:00
parent 40cff81550
commit fdfaacfbe5
9 changed files with 220 additions and 121 deletions

View File

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

View File

@ -206,14 +206,18 @@ value_t cvalue_static_cstring(char *str)
return cvalue_from_ref(stringtype, str, strlen(str), NIL); 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); value_t v = cvalue_string(n);
memcpy(cvalue_data(v), str, n); memcpy(cvalue_data(v), str, n);
return v; return v;
} }
value_t string_from_cstr(char *str)
{
return string_from_cstrn(str, strlen(str));
}
int isstring(value_t v) int isstring(value_t v)
{ {
return (iscvalue(v) && cv_isstr((cvalue_t*)ptr(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) \ #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) \ void *dest) \
{ \ { \
ctype##_t n=0; \ ctype##_t n=0; \
(void)type; \ (void)type; \
if (isfixnum(arg)) { \ if (isfixnum(arg)) { \
n = numval(arg); \ n = numval(arg); \
} \ } \
else if (iscprim(arg)) { \ else if (iscprim(arg)) { \
cprim_t *cp = (cprim_t*)ptr(arg); \ cprim_t *cp = (cprim_t*)ptr(arg); \
void *p = cp_data(cp); \ void *p = cp_data(cp); \
n = (ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \ n = (ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \
} \ } \
else { \ else { \
type_error(#typenam, "number", arg); \ return 1; \
} \ } \
*((ctype##_t*)dest) = n; \ *((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) \ value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \
{ \ { \
if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \ if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \
value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \ 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; \ return cp; \
} \ } \
value_t mk_##typenam(ctype##_t n) \ value_t mk_##typenam(ctype##_t n) \
@ -275,25 +293,25 @@ value_t mk_##typenam(ctype##_t n) \
return cp; \ 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 #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 #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 #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) value_t size_wrap(size_t sz)
{ {
@ -315,7 +333,7 @@ size_t toulong(value_t n, char *fname)
return 0; 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; int n=0;
value_t syms; value_t syms;
@ -328,7 +346,7 @@ static void cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
while (iscons(syms)) { while (iscons(syms)) {
if (car_(syms) == arg) { if (car_(syms) == arg) {
*(int*)dest = n; *(int*)dest = n;
return; return 0;
} }
n++; n++;
syms = cdr_(syms); 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)) if ((unsigned)n >= llength(syms))
lerror(ArgError, "enum: value out of range"); lerror(ArgError, "enum: value out of range");
*(int*)dest = n; *(int*)dest = n;
return 0;
} }
value_t cvalue_enum(value_t *args, u_int32_t nargs) 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; 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; value_t type = ft->type;
size_t elsize, i, cnt, sz; 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)) { if (isvector(arg)) {
array_init_fromargs((char*)dest, &vector_elt(arg,0), cnt, array_init_fromargs((char*)dest, &vector_elt(arg,0), cnt,
eltype, elsize); eltype, elsize);
return; return 0;
} }
else if (iscons(arg) || arg==NIL) { else if (iscons(arg) || arg==NIL) {
i = 0; i = 0;
@ -423,7 +442,7 @@ static void cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
lerror(ArgError, "array: size mismatch"); lerror(ArgError, "array: size mismatch");
array_init_fromargs((char*)dest, &Stack[SP-i], i, eltype, elsize); array_init_fromargs((char*)dest, &Stack[SP-i], i, eltype, elsize);
POPN(i); POPN(i);
return; return 0;
} }
else if (iscvalue(arg)) { else if (iscvalue(arg)) {
cvalue_t *cv = (cvalue_t*)ptr(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); memcpy(dest, cv_data(cv), sz);
else else
lerror(ArgError, "array: size mismatch"); lerror(ArgError, "array: size mismatch");
return; return 0;
} }
else { else {
// TODO: initialize array from different type elements // 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); cvalue_init(eltype, arg, dest);
else else
type_error("array", "sequence", arg); type_error("array", "sequence", arg);
return 0;
} }
value_t cvalue_array(value_t *args, u_int32_t nargs) 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; 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) value_t cvalue_sizeof(value_t *args, u_int32_t nargs)
{ {
argcount("sizeof", nargs, 1); argcount("sizeof", nargs, 1);
if (iscvalue(args[0])) { if (issymbol(args[0]) || iscons(args[0])) {
cvalue_t *cv = (cvalue_t*)ptr(args[0]); int a;
return size_wrap(cv_len(cv)); return size_wrap(ctype_sizeof(args[0], &a));
} }
else if (iscprim(args[0])) { size_t n; char *data;
cprim_t *cp = (cprim_t*)ptr(args[0]); to_sized_ptr(args[0], "sizeof", &data, &n);
return fixnum(cp_class(cp)->size); return size_wrap(n);
}
int a;
return size_wrap(ctype_sizeof(args[0], &a));
} }
value_t cvalue_typeof(value_t *args, u_int32_t nargs) 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) \ #define mk_primtype(name) \
name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init 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() void cvalues_init()
{ {
htable_new(&TypeTable, 256); htable_new(&TypeTable, 256);
@ -915,10 +958,15 @@ void cvalues_init()
mk_primtype(uint32); mk_primtype(uint32);
mk_primtype(int64); mk_primtype(int64);
mk_primtype(uint64); 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(float);
mk_primtype(double); mk_primtype(double);

View File

@ -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_str(char *s, ios_t *f);
void fl_print_child(ios_t *f, value_t v, int princ); 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 { typedef struct _fltype_t {
value_t type; 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_string(size_t sz);
value_t cvalue_static_cstring(char *str); value_t cvalue_static_cstring(char *str);
value_t string_from_cstr(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 isstring(value_t v);
int isnumber(value_t v); int isnumber(value_t v);
int isiostream(value_t v);
value_t cvalue_compare(value_t a, value_t b); 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_type(value_t t);
fltype_t *get_array_type(value_t eltype); fltype_t *get_array_type(value_t eltype);
fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab,

View File

@ -79,14 +79,14 @@ value_t fl_file(value_t *args, uint32_t nargs)
return f; 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; (void)args;
value_t f = cvalue(iostreamtype, sizeof(ios_t)); value_t f = cvalue(iostreamtype, sizeof(ios_t));
ios_t *s = value2c(ios_t*, f); ios_t *s = value2c(ios_t*, f);
if (ios_mem(s, 0) == NULL) if (ios_mem(s, 0) == NULL)
lerror(MemoryError, "memstream: could not allocate stream"); lerror(MemoryError, "buffer: could not allocate stream");
return f; return f;
} }
@ -113,6 +113,17 @@ value_t fl_iogetc(value_t *args, u_int32_t nargs)
return mk_wchar(wc); 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) value_t fl_ioflush(value_t *args, u_int32_t nargs)
{ {
argcount("io.flush", nargs, 1); argcount("io.flush", nargs, 1);
@ -194,29 +205,6 @@ value_t fl_ioread(value_t *args, u_int32_t nargs)
return cv; 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) value_t fl_iowrite(value_t *args, u_int32_t nargs)
{ {
argcount("io.write", nargs, 2); argcount("io.write", nargs, 2);
@ -263,11 +251,39 @@ value_t fl_ioreaduntil(value_t *args, u_int32_t nargs)
return str; 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[] = { static builtinspec_t iostreamfunc_info[] = {
{ "iostream?", fl_iostreamp }, { "iostream?", fl_iostreamp },
{ "dump", fl_dump }, { "dump", fl_dump },
{ "file", fl_file }, { "file", fl_file },
{ "memstream", fl_memstream }, { "buffer", fl_buffer },
{ "read", fl_read }, { "read", fl_read },
{ "io.print", fl_ioprint }, { "io.print", fl_ioprint },
{ "io.princ", fl_ioprinc }, { "io.princ", fl_ioprinc },
@ -275,10 +291,12 @@ static builtinspec_t iostreamfunc_info[] = {
{ "io.close", fl_ioclose }, { "io.close", fl_ioclose },
{ "io.eof?" , fl_ioeof }, { "io.eof?" , fl_ioeof },
{ "io.getc" , fl_iogetc }, { "io.getc" , fl_iogetc },
{ "io.putc" , fl_ioputc },
{ "io.discardbuffer", fl_iopurge }, { "io.discardbuffer", fl_iopurge },
{ "io.read", fl_ioread }, { "io.read", fl_ioread },
{ "io.write", fl_iowrite }, { "io.write", fl_iowrite },
{ "io.readuntil", fl_ioreaduntil }, { "io.readuntil", fl_ioreaduntil },
{ "io.tostring!", fl_iotostring },
{ NULL, NULL } { NULL, NULL }
}; };

View File

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

View File

@ -14,24 +14,17 @@
#include "llt.h" #include "llt.h"
#include "flisp.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) 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; return outp;
} }
@ -93,7 +86,7 @@ value_t fl_string_encode(value_t *args, u_int32_t nargs)
return str; 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) 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)); sz += cv_len((cvalue_t*)ptr(cv));
continue; 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 if (nargs == 1) // convert single value to string
return args[i]; return args[i];
sz += cv_len((cvalue_t*)ptr(args[i])); sz += cv_len((cvalue_t*)ptr(args[i]));

View File

@ -239,6 +239,15 @@
(define (list-ref lst n) (define (list-ref lst n)
(car (nthcdr 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) (define (list* . l)
(if (atom? (cdr l)) (if (atom? (cdr l))
(car l) (car l)
@ -408,6 +417,7 @@
(define (vals->cond key v) (define (vals->cond key v)
(cond ((eq? v 'else) 'else) (cond ((eq? v 'else) 'else)
((null? v) #f) ((null? v) #f)
((atom? v) `(eqv? ,key ,v))
((null? (cdr v)) `(eqv? ,key ,(quote-value (car v)))) ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
(else `(memv ,key ',v)))) (else `(memv ,key ',v))))
(let ((g (gensym))) (let ((g (gensym)))
@ -560,6 +570,20 @@
(trim-start s at-start 0 L) (trim-start s at-start 0 L)
(trim-end s at-end 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 (io.readline s) (io.readuntil s #byte(0xA)))
(define (repl) (define (repl)
@ -584,12 +608,9 @@
(define (print-exception e) (define (print-exception e)
(cond ((and (pair? e) (cond ((and (pair? e)
(eq? (car e) 'type-error) (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))) (io.print *stderr* (cadddr e)))
((and (pair? e) ((and (pair? e)
@ -610,9 +631,12 @@
(io.princ *stderr* "in file " (cadr e))) (io.princ *stderr* "in file " (cadr e)))
((and (list? 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: ") (else (io.princ *stderr* "*** Unhandled exception: ")
(io.print *stderr* e))) (io.print *stderr* e)))

View File

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

View File

@ -674,6 +674,7 @@ static void _ios_init(ios_t *s)
s->ownfd = 0; s->ownfd = 0;
s->_eof = 0; s->_eof = 0;
s->rereadable = 0; s->rereadable = 0;
s->readonly = 0;
} }
/* stream object initializers. we do no allocation. */ /* stream object initializers. we do no allocation. */
@ -828,6 +829,13 @@ int ios_getutf8(ios_t *s, uint32_t *pwc)
return 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) void ios_purge(ios_t *s)
{ {
if (s->state == bst_rd) { if (s->state == bst_rd) {