From 8197197ced7ee888594d4cecc1cf4617848652ef Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Mon, 5 Jan 2009 02:45:21 +0000 Subject: [PATCH] misc. cleanup adding without-delimited-continuations adding skeleton for stream objects --- femtolisp/cps.lsp | 7 ++++-- femtolisp/cvalues.c | 21 +++++++++++++++-- femtolisp/flisp.c | 2 +- femtolisp/stream.c | 56 ++++++++++++++++++++++++++++++++++++++++++++ femtolisp/system.lsp | 10 ++++---- femtolisp/table.c | 7 +++--- femtolisp/todo | 4 ++-- femtolisp/types.c | 24 ------------------- 8 files changed, 91 insertions(+), 40 deletions(-) create mode 100644 femtolisp/stream.c diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index ee92b0b..02dd64d 100644 --- a/femtolisp/cps.lsp +++ b/femtolisp/cps.lsp @@ -155,6 +155,9 @@ `(let ((,v (lambda/cc (,g ,val) (,g (,k ,val))))) ,(cps- E *top-k*)))) + ((eq (car form) 'without-delimited-continuations) + `(,k ,(cadr form))) + ((and (constantp (car form)) (builtinp (eval (car form)))) (builtincall->cps form k)) @@ -298,14 +301,14 @@ todo: (let ((x 0)) (while (< x 10) - (progn (#.print x) (setq x (+ 1 x))))) + (progn (print x) (setq x (+ 1 x))))) => (let ((x 0)) (reset (let ((l nil)) (let ((k (shift k (k k)))) (if (< x 10) - (progn (setq l (progn (#.print x) + (progn (setq l (progn (print x) (setq x (+ 1 x)))) (k k)) l))))) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 3133a5a..eca0cf5 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -827,7 +827,8 @@ value_t cbuiltin(char *name, builtin_t f) #define ctor_cv_intern(tok) \ cv_intern(tok);set(tok##sym, cbuiltin(#tok, cvalue_##tok)) -void types_init(); +#define mk_primtype(name) \ + name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init void cvalues_init() { @@ -879,7 +880,23 @@ void cvalues_init() wcstringtypesym = symbol("*wcstring-type*"); setc(wcstringtypesym, list2(arraysym, wcharsym)); - types_init(); + mk_primtype(int8); + mk_primtype(uint8); + mk_primtype(int16); + mk_primtype(uint16); + mk_primtype(int32); + mk_primtype(uint32); + mk_primtype(int64); + mk_primtype(uint64); + mk_primtype(long); + mk_primtype(ulong); + mk_primtype(byte); + mk_primtype(wchar); + mk_primtype(float); + mk_primtype(double); + + stringtype = get_type(symbol_value(stringtypesym)); + wcstringtype = get_type(symbol_value(wcstringtypesym)); emptystringsym = symbol("*empty-string*"); setc(emptystringsym, cvalue_static_cstring("")); diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 9add97e..9411b46 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -30,7 +30,7 @@ * strings - hash tables - by Jeff Bezanson (C) 2008 + by Jeff Bezanson (C) 2009 Distributed under the BSD License */ diff --git a/femtolisp/stream.c b/femtolisp/stream.c new file mode 100644 index 0000000..171471d --- /dev/null +++ b/femtolisp/stream.c @@ -0,0 +1,56 @@ +#include +#include +#include +#include +#include +#include +#include "llt.h" +#include "flisp.h" + +static value_t streamsym; +static fltype_t *streamtype; + +void print_stream(value_t v, ios_t *f, int princ) +{ +} + +void free_stream(value_t self) +{ +} + +void relocate_stream(value_t oldv, value_t newv) +{ +} + +cvtable_t stream_vtable = { print_stream, relocate_stream, free_stream, NULL }; + +int isstream(value_t v) +{ + return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == streamtype; +} + +value_t fl_streamp(value_t *args, uint32_t nargs) +{ + argcount("streamp", nargs, 1); + return isstream(args[0]) ? T : NIL; +} + +static ios_t *tostream(value_t v, char *fname) +{ + if (!isstream(v)) + type_error(fname, "stream", v); + return (ios_t*)cv_data((cvalue_t*)ptr(v)); +} + +static builtinspec_t streamfunc_info[] = { + { "streamp", fl_streamp }, + { NULL, NULL } +}; + +void stream_init() +{ + streamsym = symbol("stream"); + streamtype = define_opaque_type(streamsym, sizeof(ios_t), + &stream_vtable, NULL); + assign_global_builtins(streamfunc_info); +} diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 7a61323..514f3d5 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -1,5 +1,5 @@ ; femtoLisp standard library -; by Jeff Bezanson (C) 2008 +; by Jeff Bezanson (C) 2009 ; Distributed under the BSD License ; convert a sequence of body statements to a single expression. @@ -165,12 +165,12 @@ (defun listp (a) (or (eq a ()) (consp a))) -(defun nthcdr (n lst) +(defun nthcdr (lst n) (if (<= n 0) lst - (nthcdr (- n 1) (cdr lst)))) + (nthcdr (cdr lst) (- n 1)))) (defun list-ref (lst n) - (car (nthcdr n lst))) + (car (nthcdr lst n))) (defun list* l (if (atom (cdr l)) @@ -376,11 +376,11 @@ (cdadr rplacd cadr) (cddar rplacd cdar) (cdddr rplacd cddr) + (list-ref rplaca nthcdr) (get put identity) (aref aset identity) (symbol-function set identity) (symbol-value set identity) - (symbol-plist set-symbol-plist identity) (symbol-syntax set-syntax identity))) (defun setf-place-mutator (place val) diff --git a/femtolisp/table.c b/femtolisp/table.c index 3218fac..d856aa8 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -76,10 +76,9 @@ value_t fl_tablep(value_t *args, uint32_t nargs) static htable_t *totable(value_t v, char *fname) { - if (ishashtable(v)) - return (htable_t*)cv_data((cvalue_t*)ptr(v)); - type_error(fname, "table", v); - return NULL; + if (!ishashtable(v)) + type_error(fname, "table", v); + return (htable_t*)cv_data((cvalue_t*)ptr(v)); } value_t fl_table(value_t *args, uint32_t nargs) diff --git a/femtolisp/todo b/femtolisp/todo index 1aeb29f..611fa0a 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -834,8 +834,8 @@ String API IOStream API read - (read[ stream]) ; get next sexpr from stream - print, sprint - princ, sprinc + print + princ iostream - (stream[ cvalue-as-bytestream]) file stream.eof diff --git a/femtolisp/types.c b/femtolisp/types.c index 7dcfa34..a5660a9 100644 --- a/femtolisp/types.c +++ b/femtolisp/types.c @@ -93,27 +93,3 @@ void relocate_typetable() } } } - -#define mk_primtype(name) \ - name##type=get_type(name##sym);name##type->init = &cvalue_##name##_init - -void types_init() -{ - mk_primtype(int8); - mk_primtype(uint8); - mk_primtype(int16); - mk_primtype(uint16); - mk_primtype(int32); - mk_primtype(uint32); - mk_primtype(int64); - mk_primtype(uint64); - mk_primtype(long); - mk_primtype(ulong); - mk_primtype(byte); - mk_primtype(wchar); - mk_primtype(float); - mk_primtype(double); - - stringtype = get_type(symbol_value(stringtypesym)); - wcstringtype = get_type(symbol_value(wcstringtypesym)); -}