lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
femtolisp/cps.lsp
View File

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

132
femtolisp/cvalues.c
View File

@ -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) \
static void cvalue_##typenam##_init(fltype_t *type, value_t arg, \
#define num_init(ctype, cnvt, tag) \
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, \
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,20 +613,40 @@ 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));
}
else if (iscprim(args[0])) {
cprim_t *cp = (cprim_t*)ptr(args[0]);
return fixnum(cp_class(cp)->size);
}
if (issymbol(args[0]) || iscons(args[0])) {
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);

6
femtolisp/flisp.h
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_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,

72
femtolisp/iostream.c
View File

@ -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 }
};

2
femtolisp/read.c
View File

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

29
femtolisp/string.c
View File

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

42
femtolisp/system.lsp
View File

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

8
femtolisp/todo
View File

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

8
llt/ios.c
View File

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