allowing logand, logior, logxor to accept any number of arguments

adding negative?, positive?, zero?, even?, odd?, for-each
adding *linefeed*, terpri

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

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 (nargs == 0)
-            if (bothfixnums(Stack[SP-1], Stack[SP-2]))
+                v = fixnum(-1);
-                v = Stack[SP-1] & Stack[SP-2];
+            else {
-            else
+                v = Stack[SP-nargs];
-                v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 0, "&");
+                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 (nargs == 0)
-            if (bothfixnums(Stack[SP-1], Stack[SP-2]))
+                v = fixnum(0);
-                v = Stack[SP-1] | Stack[SP-2];
+            else {
-            else
+                v = Stack[SP-nargs];
-                v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 1, "!");
+                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 (nargs == 0)
-            if (bothfixnums(Stack[SP-1], Stack[SP-2]))
+                v = fixnum(0);
-                v = fixnum(numval(Stack[SP-1]) ^ numval(Stack[SP-2]));
+            else {
-            else
+                v = Stack[SP-nargs];
-                v = fl_bitwise_op(Stack[SP-2], Stack[SP-1], 2, "$");
+                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);

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;
 

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

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

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