diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index dadf712..5024a3f 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -490,26 +490,6 @@ size_t cvalue_arraylen(value_t v) return cv_len(cv)/(cv_class(cv)->elsz); } -static value_t cvalue_relocate(value_t v) -{ - size_t nw; - cvalue_t *cv = (cvalue_t*)ptr(v); - cvalue_t *nv; - value_t ncv; - - nw = cv_nwords(cv); - nv = (cvalue_t*)alloc_words(nw); - memcpy(nv, cv, nw*sizeof(value_t)); - if (isinlined(cv)) - nv->data = &nv->_space[0]; - ncv = tagptr(nv, TAG_CVALUE); - fltype_t *t = cv_class(cv); - if (t->vtable != NULL && t->vtable->relocate != NULL) - t->vtable->relocate(v, ncv); - forward(v, ncv); - return ncv; -} - static size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal, int *palign) { @@ -664,6 +644,26 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs) return cv_type((cvalue_t*)ptr(args[0])); } +value_t cvalue_relocate(value_t v) +{ + size_t nw; + cvalue_t *cv = (cvalue_t*)ptr(v); + cvalue_t *nv; + value_t ncv; + + nw = cv_nwords(cv); + nv = (cvalue_t*)alloc_words(nw); + memcpy(nv, cv, nw*sizeof(value_t)); + if (isinlined(cv)) + nv->data = &nv->_space[0]; + ncv = tagptr(nv, TAG_CVALUE); + fltype_t *t = cv_class(cv); + if (t->vtable != NULL && t->vtable->relocate != NULL) + t->vtable->relocate(v, ncv); + forward(v, ncv); + return ncv; +} + value_t cvalue_copy(value_t v) { assert(iscvalue(v)); diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index a81535e..0edd219 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -10,7 +10,7 @@ it uses a Scheme-style evaluation rule where any expression may appear in head position as long as it evaluates to a function. it uses Scheme-style varargs (dotted formal argument lists) - lambdas can have only 1 body expression; use (progn ...) for multiple + lambdas can have only 1 body expression; use (begin ...) for multiple expressions. this is due to the closure representation (lambda args body . env) @@ -29,6 +29,7 @@ * constructor notation for nicely printing arbitrary values * strings * hash tables + * I/O streams by Jeff Bezanson (C) 2009 Distributed under the BSD License @@ -894,7 +895,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) } v = *pv; break; - case F_PROGN: + case F_BEGIN: // return last arg pv = &Stack[saveSP]; if (iscons(*pv)) { @@ -1153,25 +1154,52 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) v = fl_bitwise_not(Stack[SP-1]); break; case F_BAND: - argcount("logand", nargs, 2); - if (bothfixnums(Stack[SP-1], Stack[SP-2])) - v = Stack[SP-1] & Stack[SP-2]; - else - v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 0, "&"); + if (nargs == 0) + v = fixnum(-1); + else { + v = Stack[SP-nargs]; + while (nargs > 1) { + e = Stack[SP-nargs+1]; + if (bothfixnums(v, e)) + v = v & e; + else + v = fl_bitwise_op(v, e, 0, "&"); + nargs--; + Stack[SP-nargs] = v; + } + } break; case F_BOR: - argcount("logior", nargs, 2); - if (bothfixnums(Stack[SP-1], Stack[SP-2])) - v = Stack[SP-1] | Stack[SP-2]; - else - v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 1, "!"); + if (nargs == 0) + v = fixnum(0); + else { + v = Stack[SP-nargs]; + while (nargs > 1) { + e = Stack[SP-nargs+1]; + if (bothfixnums(v, e)) + v = v | e; + else + v = fl_bitwise_op(v, e, 1, "!"); + nargs--; + Stack[SP-nargs] = v; + } + } break; case F_BXOR: - argcount("logxor", nargs, 2); - if (bothfixnums(Stack[SP-1], Stack[SP-2])) - v = fixnum(numval(Stack[SP-1]) ^ numval(Stack[SP-2])); - else - v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$"); + if (nargs == 0) + v = fixnum(0); + else { + v = Stack[SP-nargs]; + while (nargs > 1) { + e = Stack[SP-nargs+1]; + if (bothfixnums(v, e)) + v = fixnum(numval(v) ^ numval(e)); + else + v = fl_bitwise_op(v, e, 2, "$"); + nargs--; + Stack[SP-nargs] = v; + } + } break; case F_ASH: argcount("ash", nargs, 2); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index efbc2bc..6a28abf 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -102,7 +102,7 @@ extern uint32_t SP; enum { // special forms F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA, - F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROGN, + F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_BEGIN, // functions F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP, @@ -116,7 +116,7 @@ enum { F_TRUE, F_FALSE, F_NIL, N_BUILTINS, }; -#define isspecial(v) (uintval(v) <= (unsigned int)F_PROGN) +#define isspecial(v) (uintval(v) <= (unsigned int)F_BEGIN) extern value_t NIL, FL_T, FL_F; diff --git a/femtolisp/rule30.lsp b/femtolisp/rule30.lsp new file mode 100644 index 0000000..713d01b --- /dev/null +++ b/femtolisp/rule30.lsp @@ -0,0 +1,39 @@ +; -*- scheme -*- + +(define (rule30-step b) + (let ((L (ash b -1)) + (R (ash b 1))) + (let ((~b (lognot b)) + (~L (lognot L)) + (~R (lognot R))) + (logior (logand L ~b ~R) + (logand ~L b R) + (logand ~L b ~R) + (logand ~L ~b R))))) + +(define (nestlist f zero n) + (if (<= n 0) () + (cons zero (nestlist f (f zero) (- n 1))))) + +(define (make-string k ch) + (cond ((<= k 0) "") + ((= k 1) (string ch)) + ((= k 2) (string ch ch)) + ((odd? k) (string ch (make-string (- k 1) ch))) + (else (let ((half (make-string (/ k 2) ch))) + (string half half))))) + +(define (pad0 s n) (string (make-string (- n (length s)) "0") s)) + +(define (bin-draw s) + (string.map (lambda (c) (case c + (#\1 #\#) + (#\0 #\ ) + (else c))) + s)) + +(for-each (lambda (n) + (begin + (princ (bin-draw (pad0 (number->string n 2) 63))) + (terpri))) + (nestlist rule30-step (uint64 0x0000000080000000) 32)) diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 0ceda9e..1c34da2 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -195,6 +195,11 @@ (define (> a b) (< b a)) (define (<= a b) (not (< b a))) (define (>= a b) (not (< a b))) +(define (negative? x) (< x 0)) +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (even? x) (= (logand x 1) 0)) +(define (odd? x) (not (even? x))) (define (1+ n) (+ n 1)) (define (1- n) (- n 1)) (define (mod x y) (- x (* (/ x y) y))) @@ -467,6 +472,12 @@ (define (iota n) (map-int identity n)) (define ι iota) +(define (for-each f l) + (when (pair? l) + (begin (f (car l)) + (for-each f (cdr l)))) + #t) + (define (error . args) (raise (cons 'error args))) (define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value))) @@ -485,6 +496,14 @@ (lambda (,e) (begin ,finally (raise ,e)))) ,finally))) +(if (or (eq? *os-name* 'win32) + (eq? *os-name* 'win64) + (eq? *os-name* 'windows)) + (begin (define *directory-separator* "\\") + (define *linefeed* "\r\n")) + (begin (define *directory-separator* "/") + (define *linefeed* "\n"))) + (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr)))) (define-macro (time expr) @@ -494,8 +513,9 @@ ,expr (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) +(define (terpri) (princ *linefeed*)) (define (display x) (princ x) #t) -(define (println . args) (prog1 (apply print args) (princ "\n"))) +(define (println . args) (prog1 (apply print args) (terpri))) (define (vu8 . elts) (apply array (cons 'uint8 elts))) @@ -598,12 +618,12 @@ (set! that V) #t)))) (define (reploop) - (when (trycatch (and (prompt) (princ "\n")) + (when (trycatch (and (prompt) (terpri)) print-exception) - (begin (princ "\n") + (begin (terpri) (reploop)))) (reploop) - (princ "\n")) + (terpri)) (define (print-exception e) (cond ((and (pair? e) @@ -641,7 +661,7 @@ (else (io.princ *stderr* "*** Unhandled exception: ") (io.print *stderr* e))) - (io.princ *stderr* "\n") + (io.princ *stderr* *linefeed*) #t) (define (__script fname) @@ -649,12 +669,6 @@ (lambda (e) (begin (print-exception e) (exit 1))))) -(if (or (eq? *os-name* 'win32) - (eq? *os-name* 'win64) - (eq? *os-name* 'windows)) - (define *directory-separator* "\\") - (define *directory-separator* "/")) - (define (__start . argv) ; reload this file with our new definition of load (load (string *install-dir* *directory-separator* "system.lsp")) diff --git a/femtolisp/todo b/femtolisp/todo index 244695c..a3b3737 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -848,10 +848,10 @@ IOStream API *princ *file iostream - (stream[ cvalue-as-bytestream]) -*memstream +*buffer fifo socket -*io.eof +*io.eof? *io.flush *io.close *io.discardbuffer @@ -950,7 +950,7 @@ consolidated todo list as of 8/30: * finalizers in gc * hashtable * generic aref/aset -- expose io stream object +* expose io stream object * new toplevel * make raising a memory error non-consing