ref: bfa30fb095ba0e1ab30e606715557c69099e47aa
parent: d81e6c2d57c8d38c7ce80ede40734ba52bc0dffd
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Mar 11 22:47:34 EDT 2009
allowing logand, logior, logxor to accept any number of arguments adding negative?, positive?, zero?, even?, odd?, for-each adding *linefeed*, terpri
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -490,26 +490,6 @@
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)
{@@ -662,6 +642,26 @@
return builtinsym;
}
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)
--- 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 @@
}
v = *pv;
break;
- case F_PROGN:
+ case F_BEGIN:
// return last arg
pv = &Stack[saveSP];
if (iscons(*pv)) {@@ -1153,25 +1154,52 @@
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);--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -102,7 +102,7 @@
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 @@
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;
--- /dev/null
+++ b/femtolisp/rule30.lsp
@@ -1,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))
--- 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)
@@ -648,12 +668,6 @@
(trycatch (load fname)
(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
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -848,10 +848,10 @@
*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 @@
* finalizers in gc
* hashtable
* generic aref/aset
-- expose io stream object
+* expose io stream object
* new toplevel
* make raising a memory error non-consing