ref: ed2b11a8ac69cd8296aa0910f2f08c5f2cab2752
parent: 21dd64045484411ef9c9f218c1490fd02c02b3fd
author: Jeff Bezanson <[email protected]>
date: Fri Feb 17 12:38:10 EST 2012
some cleanup
--- /dev/null
+++ b/femtolisp/.gitignore
@@ -1,0 +1,4 @@
+/*.o
+/*.do
+/*.a
+/flisp
--- a/femtolisp/100x100.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-'#0=(#198=(#197=(#196=(#195=(#194=(#193=(#192=(#191=(#190=(#189=(#188=(#187=(#186=(#185=(#184=(#183=(#182=(#181=(#180=(#179=(#178=(#177=(#176=(#175=(#174=(#173=(#172=(#171=(#170=(#169=(#168=(#167=(#166=(#165=(#164=(#163=(#162=(#161=(#160=(#159=(#158=(#157=(#156=(#155=(#154=(#153=(#152=(#151=(#150=(#149=(#148=(#147=(#146=(#145=(#144=(#143=(#142=(#141=(#140=(#139=(#138=(#137=(#136=(#135=(#134=(#133=(#132=(#131=(#130=(#129=(#128=(#127=(#126=(#125=(#124=(#123=(#122=(#121=(#120=(#119=(#118=(#117=(#116=(#115=(#114=(#113=(#112=(#111=(#110=(#109=(#108=(#107=(#106=(#105=(#104=(#103=(#102=(#101=(#100=(#0# . #1=(#9999=(#9998=(#9997=(#9996=(#9995=(#9994=(#9993=(#9992=(#9991=(#9990=(#9989=(#9988=(#9987=(#9986=(#9985=(#9984=(#9983=(#9982=(#9981=(#9980=(#9979=(#9978=(#9977=(#9976=(#9975=(#9974=(#9973=(#9972=(#9971=(#9970=(#9969=(#9968=(#9967=(#9966=(#9965=(#9964=(#9963=(#9962=(#9961=(#9960=(#9959=(#9958=(#9957=(#9956=(#9955=(#9954=(#9953=(#9952=(#9951=(#9950=(#9949=(#9948=(#9947=(#9946=(#9945=(#9944=(#9943=(#9942=(#9941=(#9940=(#9939=(#9938=(#9937=(#9936=(#9935=(#9934=(#9933=(#9932=(#9931=(#9930=(#9929=(#9928=(#9927=(#9926=(#9925=(#9924=(#9923=(#9922=(#9921=(#9920=(#9919=(#9918=(#9917=(#9916=(#9915=(#9914=(#9913=(#9912=(#9911=(#9910=(#9909=(#9908=(#9907=(#9906=(#9905=(#9904=(#9903=(#9902=(#9901=(#1# . #2=(#9900=(#9899=(#9898=(#9897=(#9896=(#9895=(#9894=(#9893=(#9892=(#9891=(#9890=(#9889=(#9888=(#9887=(#9886=(#9885=(#9884=(#9883=(#9882=(#9881=(#9880=(#9879=(#9878=(#9877=(#9876=(#9875=(#9874=(#9873=(#9872=(#9871=(#9870=(#9869=(#9868=(#9867=(#9866=(#9865=(#9864=(#9863=(#9862=(#9861=(#9860=(#9859=(#9858=(#9857=(#9856=(#9855=(#9854=(#9853=(#9852=(#9851=(#9850=(#9849=(#9848=(#9847=(#9846=(#9845=(#9844=(#9843=(#9842=(#9841=(#9840=(#9839=(#9838=(#9837=(#9836=(#9835=(#9834=(#9833=(#9832=(#9831=(#9830=(#9829=(#9828=(#9827=(#9826=(#9825=(#9824=(#9823=(#9822=(#9821=(#9820=(#9819=(#9818=(#9817=(#9816=(#9815=(#9814=(#9813=(#9812=(#9811=(#9810=(#9809=(#9808=(#9807=(#9806=(#9805=(#9804=(#9803=(#9802=(#2# . #3=(#9801=(#9800=(#9799=(#9798=(#9797=(#9796=(#9795=(#9794=(#9793=(#9792=(#9791=(#9790=(#9789=(#9788=(#9787=(#9786=(#9785=(#9784=(#9783=(#9782=(#9781=(#9780=(#9779=(#9778=(#9777=(#9776=(#9775=(#9774=(#9773=(#9772=(#9771=(#9770=(#9769=(#9768=(#9767=(#9766=(#9765=(#9764=(#9763=(#9762=(#9761=(#9760=(#9759=(#9758=(#9757=(#9756=(#9755=(#9754=(#9753=(#9752=(#9751=(#9750=(#9749=(#9748=(#9747=(#9746=(#9745=(#9744=(#9743=(#9742=(#9741=(#9740=(#9739=(#9738=(#9737=(#9736=(#9735=(#9734=(#9733=(#9732=(#9731=(#9730=(#9729=(#9728=(#9727=(#9726=(#9725=(#9724=(#9723=(#9722=(#9721=(#9720=(#9719=(#9718=(#9717=(#9716=(#9715=(#9714=(#9713=(#9712=(#9711=(#9710=(#9709=(#9708=(#9707=(#9706=(#9705=(#9704=(#9703=(#3# . #4=(#9702=(#9701=(#9700=(#9699=(#9698=(#9697=(#9696=(#9695=(#9694=(#9693=(#9692=(#9691=(#9690=(#9689=(#9688=(#9687=(#9686=(#9685=(#9684=(#9683=(#9682=(#9681=(#9680=(#9679=(#9678=(#9677=(#9676=(#9675=(#9674=(#9673=(#9672=(#9671=(#9670=(#9669=(#9668=(#9667=(#9666=(#9665=(#9664=(#9663=(#9662=(#9661=(#9660=(#9659=(#9658=(#9657=(#9656=(#9655=(#9654=(#9653=(#9652=(#9651=(#9650=(#9649=(#9648=(#9647=(#9646=(#9645=(#9644=(#9643=(#9642=(#9641=(#9640=(#9639=(#9638=(#9637=(#9636=(#9635=(#9634=(#9633=(#9632=(#9631=(#9630=(#9629=(#9628=(#9627=(#9626=(#9625=(#9624=(#9623=(#9622=(#9621=(#9620=(#9619=(#9618=(#9617=(#9616=(#9615=(#9614=(#9613=(#9612=(#9611=(#9610=(#9609=(#9608=(#9607=(#9606=(#9605=(#9604=(#4# . #5=(#9603=(#9602=(#9601=(#9600=(#9599=(#9598=(#9597=(#9596=(#9595=(#9594=(#9593=(#9592=(#9591=(#9590=(#9589=(#9588=(#9587=(#9586=(#9585=(#9584=(#9583=(#9582=(#9581=(#9580=(#9579=(#9578=(#9577=(#9576=(#9575=(#9574=(#9573=(#9572=(#9571=(#9570=(#9569=(#9568=(#9567=(#9566=(#9565=(#9564=(#9563=(#9562=(#9561=(#9560=(#9559=(#9558=(#9557=(#9556=(#9555=(#9554=(#9553=(#9552=(#9551=(#9550=(#9549=(#9548=(#9547=(#9546=(#9545=(#9544=(#9543=(#9542=(#9541=(#9540=(#9539=(#9538=(#9537=(#9536=(#9535=(#9534=(#9533=(#9532=(#9531=(#9530=(#9529=(#9528=(#9527=(#9526=(#9525=(#9524=(#9523=(#9522=(#9521=(#9520=(#9519=(#9518=(#9517=(#9516=(#9515=(#9514=(#9513=(#9512=(#9511=(#9510=(#9509=(#9508=(#9
\ No newline at end of file
--- a/femtolisp/Makefile
+++ b/femtolisp/Makefile
@@ -22,7 +22,7 @@
default: release test
test:
- ./flisp unittest.lsp
+ cd tests && ../flisp unittest.lsp
%.o: %.c
$(CC) $(SHIPFLAGS) -c $< -o $@
--- a/femtolisp/bq.scm
+++ /dev/null
@@ -1,122 +1,0 @@
-(define (bq-process2 x d)
- (define (splice-form? x)
- (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
- (eq? (car x) 'unquote-nsplicing)
- (and (eq? (car x) 'unquote)
- (length> x 2))))
- (eq? x 'unquote)))
- ;; bracket without splicing
- (define (bq-bracket1 x)
- (if (and (pair? x) (eq? (car x) 'unquote))
- (if (= d 0)
- (cadr x)
- (list cons ''unquote
- (bq-process2 (cdr x) (- d 1))))
- (bq-process2 x d)))
- (define (bq-bracket x)
- (cond ((atom? x) (list list (bq-process2 x d)))
- ((eq? (car x) 'unquote)
- (if (= d 0)
- (cons list (cdr x))
- (list list (list cons ''unquote
- (bq-process2 (cdr x) (- d 1))))))
- ((eq? (car x) 'unquote-splicing)
- (if (= d 0)
- (list 'copy-list (cadr x))
- (list list (list list ''unquote-splicing
- (bq-process2 (cadr x) (- d 1))))))
- ((eq? (car x) 'unquote-nsplicing)
- (if (= d 0)
- (cadr x)
- (list list (list list ''unquote-nsplicing
- (bq-process2 (cadr x) (- d 1))))))
- (else (list list (bq-process2 x d)))))
- (cond ((symbol? x) (list 'quote x))
- ((vector? x)
- (let ((body (bq-process2 (vector->list x) d)))
- (if (eq? (car body) list)
- (cons vector (cdr body))
- (list apply vector body))))
- ((atom? x) x)
- ((eq? (car x) 'quasiquote)
- (list list ''quasiquote (bq-process2 (cadr x) (+ d 1))))
- ((eq? (car x) 'unquote)
- (if (and (= d 0) (length= x 2))
- (cadr x)
- (list cons ''unquote (bq-process2 (cdr x) (- d 1)))))
- ((or (> d 0) (not (any splice-form? x)))
- (let ((lc (lastcdr x))
- (forms (map bq-bracket1 x)))
- (if (null? lc)
- (cons list forms)
- (if (null? (cdr forms))
- (list cons (car forms) (bq-process2 lc d))
- (nconc (cons list* forms) (list (bq-process2 lc d)))))))
- (else
- (let loop ((p x) (q ()))
- (cond ((null? p) ;; proper list
- (cons 'nconc (reverse! q)))
- ((pair? p)
- (cond ((eq? (car p) 'unquote)
- ;; (... . ,x)
- (cons 'nconc
- (nreconc q
- (if (= d 0)
- (cdr p)
- (list (list list ''unquote)
- (bq-process2 (cdr p)
- (- d 1)))))))
- (else
- (loop (cdr p) (cons (bq-bracket (car p)) q)))))
- (else
- ;; (... . x)
- (cons 'nconc (reverse! (cons (bq-process2 p d) q)))))))))
-
-#|
-tests
-
-> ``(,a ,,a ,b ,@b ,,@b)
-`(,a ,1 ,b ,@b (unquote 2 3))
-> `(,a ,1 ,b ,@b (unquote 2 3))
-(1 1 (2 3) 2 3 2 3)
-
-(define a 1)
-
-(bq-process2 '`(,a (unquote unquote a)) 0)
-
-(define b '(unquote a))
-(define unquote 88)
-(bq-process2 '``(,a ,,,@b) 0)
-; etc. => (1 88 1)
-
-(define b '(a a))
-(bq-process2 '``(,a ,,,@b) 0)
-; etc. => (1 1 1)
-|#
-
-;; minimal version with no optimizations, vectors, or dotted lists
-(define (bq-process0 x d)
- (define (bq-bracket x)
- (cond ((and (pair? x) (eq? (car x) 'unquote))
- (if (= d 0)
- (cons list (cdr x))
- (list list (list cons ''unquote
- (bq-process0 (cdr x) (- d 1))))))
- ((and (pair? x) (eq? (car x) 'unquote-splicing))
- (if (= d 0)
- (list 'copy-list (cadr x))
- (list list (list list ''unquote-splicing
- (bq-process0 (cadr x) (- d 1))))))
- (else (list list (bq-process0 x d)))))
- (cond ((symbol? x) (list 'quote x))
- ((atom? x) x)
- ((eq? (car x) 'quasiquote)
- (list list ''quasiquote (bq-process0 (cadr x) (+ d 1))))
- ((eq? (car x) 'unquote)
- (if (and (= d 0) (length= x 2))
- (cadr x)
- (list cons ''unquote (bq-process0 (cdr x) (- d 1)))))
- (else
- (cons 'nconc (map bq-bracket x)))))
-
-#t
--- a/femtolisp/color.lsp
+++ /dev/null
@@ -1,89 +1,0 @@
-; -*- scheme -*-
-
-; dictionaries ----------------------------------------------------------------
-(define (dict-new) ())
-
-(define (dict-extend dl key value)
- (cond ((null? dl) (list (cons key value)))
- ((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
- (else (cons (car dl) (dict-extend (cdr dl) key value)))))
-
-(define (dict-lookup dl key)
- (cond ((null? dl) ())
- ((equal? key (caar dl)) (cdar dl))
- (else (dict-lookup (cdr dl) key))))
-
-(define (dict-keys dl) (map car dl))
-
-; graphs ----------------------------------------------------------------------
-(define (graph-empty) (dict-new))
-
-(define (graph-connect g n1 n2)
- (dict-extend
- (dict-extend g n2 (cons n1 (dict-lookup g n2)))
- n1
- (cons n2 (dict-lookup g n1))))
-
-(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
-
-(define (graph-neighbors g n) (dict-lookup g n))
-
-(define (graph-nodes g) (dict-keys g))
-
-(define (graph-add-node g n1) (dict-extend g n1 ()))
-
-(define (graph-from-edges edge-list)
- (if (null? edge-list)
- (graph-empty)
- (graph-connect (graph-from-edges (cdr edge-list))
- (caar edge-list)
- (cdar edge-list))))
-
-; graph coloring --------------------------------------------------------------
-(define (node-colorable? g coloring node-to-color color-of-node)
- (not (member
- color-of-node
- (map
- (lambda (n)
- (let ((color-pair (assq n coloring)))
- (if (pair? color-pair) (cdr color-pair) ())))
- (graph-neighbors g node-to-color)))))
-
-(define (try-each f lst)
- (if (null? lst) #f
- (let ((ret (f (car lst))))
- (if ret ret (try-each f (cdr lst))))))
-
-(define (color-node g coloring colors uncolored-nodes color)
- (cond
- ((null? uncolored-nodes) coloring)
- ((node-colorable? g coloring (car uncolored-nodes) color)
- (let ((new-coloring
- (cons (cons (car uncolored-nodes) color) coloring)))
- (try-each (lambda (c)
- (color-node g new-coloring colors (cdr uncolored-nodes) c))
- colors)))))
-
-(define (color-graph g colors)
- (if (null? colors)
- (and (null? (graph-nodes g)) ())
- (color-node g () colors (graph-nodes g) (car colors))))
-
-(define (color-pairs pairs colors)
- (color-graph (graph-from-edges pairs) colors))
-
-; queens ----------------------------------------------------------------------
-(define (can-attack x y)
- (let ((x1 (mod x 5))
- (y1 (truncate (/ x 5)))
- (x2 (mod y 5))
- (y2 (truncate (/ y 5))))
- (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
-
-(define (generate-5x5-pairs)
- (let ((result ()))
- (dotimes (x 25)
- (dotimes (y 25)
- (if (and (not (= x y)) (can-attack x y))
- (set! result (cons (cons x y) result)) ())))
- result))
--- a/femtolisp/cps.lsp
+++ /dev/null
@@ -1,308 +1,0 @@
-; -*- scheme -*-
-(define (begin->cps forms k)
- (cond ((atom? forms) `(,k ,forms))
- ((null? (cdr forms)) (cps- (car forms) k))
- (#t (let ((_ (gensym))) ; var to bind ignored value
- (cps- (car forms) `(lambda (,_)
- ,(begin->cps (cdr forms) k)))))))
-
-(define-macro (lambda/cc args body)
- `(cons 'lambda/cc (lambda ,args ,body)))
-
-; a utility used at run time to dispatch a call with or without
-; the continuation argument, depending on the function
-(define (funcall/cc f k . args)
- (if (and (pair? f) (eq (car f) 'lambda/cc))
- (apply (cdr f) (cons k args))
- (k (apply f args))))
-(define *funcall/cc-names*
- (list->vector
- (map (lambda (i) (symbol (string 'funcall/cc- i)))
- (iota 6))))
-(define-macro (def-funcall/cc-n args)
- (let ((name (aref *funcall/cc-names* (length args))))
- `(define (,name f k ,@args)
- (if (and (pair? f) (eq (car f) 'lambda/cc))
- ((cdr f) k ,@args)
- (k (f ,@args))))))
-(def-funcall/cc-n ())
-(def-funcall/cc-n (a0))
-(def-funcall/cc-n (a0 a1))
-(def-funcall/cc-n (a0 a1 a2))
-(def-funcall/cc-n (a0 a1 a2 a3))
-(def-funcall/cc-n (a0 a1 a2 a3 a4))
-
-(define (rest->cps xformer form k argsyms)
- (let ((el (car form)))
- (if (or (atom? el) (constant? el))
- (xformer (cdr form) k (cons el argsyms))
- (let ((g (gensym)))
- (cps- el `(lambda (,g)
- ,(xformer (cdr form) k (cons g argsyms))))))))
-
-(define (make-funcall/cc head ke args)
- (let ((n (length args)))
- (if (< n 6)
- `(,(aref *funcall/cc-names* n) ,head ,ke ,@args)
- `(funcall/cc ,head ,ke ,@args))))
-
-; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
-(define (app->cps form k argsyms)
- (cond ((atom? form)
- (let ((r (reverse argsyms)))
- (make-funcall/cc (car r) k (cdr r))))
- (#t (rest->cps app->cps form k argsyms))))
-
-; (+ x) => (cps- x `(lambda (X) (,k (+ X))))
-(define (builtincall->cps form k)
- (prim->cps (cdr form) k (list (car form))))
-(define (prim->cps form k argsyms)
- (cond ((atom? form) `(,k ,(reverse argsyms)))
- (#t (rest->cps prim->cps form k argsyms))))
-
-(define *top-k* (gensym))
-(set-top-level-value! *top-k* identity)
-
-(define (cps form)
- (η-reduce
- (β-reduce
- (expand
- (cps- (expand form) *top-k*)))))
-(define (cps- form k)
- (let ((g (gensym)))
- (cond ((or (atom? form) (constant? form))
- `(,k ,form))
-
- ((eq (car form) 'lambda)
- `(,k (lambda/cc ,(cons g (cadr form)) ,(cps- (caddr form) g))))
-
- ((eq (car form) 'begin)
- (begin->cps (cdr form) k))
-
- ((eq (car form) 'if)
- (let ((test (cadr form))
- (then (caddr form))
- (else (cadddr form)))
- (if (atom? k)
- (cps- test `(lambda (,g)
- (if ,g
- ,(cps- then k)
- ,(cps- else k))))
- `(let ((,g ,k))
- ,(cps- form g)))))
-
- ((eq (car form) 'and)
- (cond ((atom? (cdr form)) `(,k #t))
- ((atom? (cddr form)) (cps- (cadr form) k))
- (#t
- (if (atom? k)
- (cps- (cadr form)
- `(lambda (,g)
- (if ,g ,(cps- `(and ,@(cddr form)) k)
- (,k ,g))))
- `(let ((,g ,k))
- ,(cps- form g))))))
-
- ((eq (car form) 'or)
- (cond ((atom? (cdr form)) `(,k #f))
- ((atom? (cddr form)) (cps- (cadr form) k))
- (#t
- (if (atom? k)
- (cps- (cadr form)
- `(lambda (,g)
- (if ,g (,k ,g)
- ,(cps- `(or ,@(cddr form)) k))))
- `(let ((,g ,k))
- ,(cps- form g))))))
-
- ((eq (car form) 'while)
- (let ((test (cadr form))
- (body (caddr form))
- (lastval (gensym)))
- (cps- (expand
- `(let ((,lastval #f))
- ((label ,g (lambda ()
- (if ,test
- (begin (set! ,lastval ,body)
- (,g))
- ,lastval))))))
- k)))
-
- ((eq (car form) 'set!)
- (let ((var (cadr form))
- (E (caddr form)))
- (cps- E `(lambda (,g) (,k (set! ,var ,g))))))
-
- ((eq (car form) 'reset)
- `(,k ,(cps- (cadr form) *top-k*)))
-
- ((eq (car form) 'shift)
- (let ((v (cadr form))
- (E (caddr form))
- (val (gensym)))
- `(let ((,v (lambda/cc (,g ,val) (,g (,k ,val)))))
- ,(cps- E *top-k*))))
-
- ((eq (car form) 'without-delimited-continuations)
- `(,k ,(cadr form)))
-
- ((and (constant? (car form))
- (builtin? (eval (car form))))
- (builtincall->cps form k))
-
- ; ((lambda (...) body) ...)
- ((and (pair? (car form))
- (eq (caar form) 'lambda))
- (let ((largs (cadr (car form)))
- (lbody (caddr (car form))))
- (cond ((null? largs) ; ((lambda () body))
- (cps- lbody k))
- ((symbol? largs) ; ((lambda x body) args...)
- (cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k))
- (#t
- (cps- (cadr form) `(lambda (,(car largs))
- ,(cps- `((lambda ,(cdr largs) ,lbody)
- ,@(cddr form))
- k)))))))
-
- (#t
- (app->cps form k ())))))
-
-; (lambda (args...) (f args...)) => f
-; but only for constant, builtin f
-(define (η-reduce form)
- (cond ((or (atom? form) (constant? form)) form)
- ((and (eq (car form) 'lambda)
- (let ((body (caddr form))
- (args (cadr form)))
- (and (pair? body)
- (equal? (cdr body) args)
- (constant? (car (caddr form))))))
- (car (caddr form)))
- (#t (map η-reduce form))))
-
-(define (contains x form)
- (or (eq form x)
- (any (lambda (p) (contains x p)) form)))
-
-(define (β-reduce form)
- (if (or (atom? form) (constant? form))
- form
- (β-reduce- (map β-reduce form))))
-
-(define (β-reduce- form)
- ; ((lambda (f) (f arg)) X) => (X arg)
- (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)
- (eq (car body) (car args))
- (not (eq (cadr body) (car args)))
- (symbol? (cadr body)))))
- `(,(cadr form)
- ,(cadr (caddr (car form)))))
-
- ; (identity x) => x
- ((eq (car form) *top-k*)
- (cadr form))
-
- ; uncurry:
- ; ((lambda (p1) ((lambda (args...) body) exprs...)) s) =>
- ; ((lambda (p1 args...) body) s exprs...)
- ; where exprs... doesn't contain p1
- ((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)
- (pair? body)
- (pair? (car body))
- (eq (caar body) 'lambda)
- (let ((innerargs (cadr (car body)))
- (innerbody (caddr (car body)))
- (params (cdr body)))
- (and (not (contains (car args) params))
- `((lambda ,(cons (car args) innerargs)
- ,innerbody)
- ,s
- ,@params)))))))
-
- (#t form)))
-
-(define-macro (with-delimited-continuations . code)
- (cps `((lambda () ,@code))))
-
-(define-macro (define-generator form . body)
- (let ((ko (gensym))
- (cur (gensym))
- (name (car form))
- (args (cdr form)))
- `(define (,name ,@args)
- (let ((,ko #f)
- (,cur #f))
- (lambda ()
- (with-delimited-continuations
- (if ,ko (,ko ,cur)
- (reset
- (let ((yield
- (lambda (v)
- (shift yk
- (begin (set! ,ko yk)
- (set! ,cur v))))))
- ,@body)))))))))
-
-; a test case
-(define-generator (range-iterator lo hi)
- ((label loop
- (lambda (i)
- (if (< hi i)
- 'done
- (begin (yield i)
- (loop (+ 1 i))))))
- lo))
-
-; example from Chung-chieh Shan's paper
-(assert (equal?
- (with-delimited-continuations
- (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
- '(a 1 b b c)))
-
-#t
-
-#|
-todo:
-* tag lambdas that accept continuation arguments, compile computed
- calls to calls to funcall/cc that does the right thing for both
- cc-lambdas and normal lambdas
-
-* handle dotted arglists in lambda
-
-- optimize constant functions, e.g. (funcall/cc-0 #:g65 (lambda (#:g58) 'done))
-
-- implement CPS version of apply
-
-- use fewer gensyms
-
- here's an alternate way to transform a while loop:
-
- (let ((x 0))
- (while (< x 10)
- (begin (print x) (set! x (+ 1 x)))))
- =>
- (let ((x 0))
- (reset
- (let ((l #f))
- (let ((k (shift k (k k))))
- (if (< x 10)
- (begin (set! l (begin (print x)
- (set! x (+ 1 x))))
- (k k))
- l)))))
-|#
--- /dev/null
+++ b/femtolisp/examples/bq.scm
@@ -1,0 +1,122 @@
+(define (bq-process2 x d)
+ (define (splice-form? x)
+ (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
+ (eq? (car x) 'unquote-nsplicing)
+ (and (eq? (car x) 'unquote)
+ (length> x 2))))
+ (eq? x 'unquote)))
+ ;; bracket without splicing
+ (define (bq-bracket1 x)
+ (if (and (pair? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cadr x)
+ (list cons ''unquote
+ (bq-process2 (cdr x) (- d 1))))
+ (bq-process2 x d)))
+ (define (bq-bracket x)
+ (cond ((atom? x) (list list (bq-process2 x d)))
+ ((eq? (car x) 'unquote)
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process2 (cdr x) (- d 1))))))
+ ((eq? (car x) 'unquote-splicing)
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process2 (cadr x) (- d 1))))))
+ ((eq? (car x) 'unquote-nsplicing)
+ (if (= d 0)
+ (cadr x)
+ (list list (list list ''unquote-nsplicing
+ (bq-process2 (cadr x) (- d 1))))))
+ (else (list list (bq-process2 x d)))))
+ (cond ((symbol? x) (list 'quote x))
+ ((vector? x)
+ (let ((body (bq-process2 (vector->list x) d)))
+ (if (eq? (car body) list)
+ (cons vector (cdr body))
+ (list apply vector body))))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process2 (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process2 (cdr x) (- d 1)))))
+ ((or (> d 0) (not (any splice-form? x)))
+ (let ((lc (lastcdr x))
+ (forms (map bq-bracket1 x)))
+ (if (null? lc)
+ (cons list forms)
+ (if (null? (cdr forms))
+ (list cons (car forms) (bq-process2 lc d))
+ (nconc (cons list* forms) (list (bq-process2 lc d)))))))
+ (else
+ (let loop ((p x) (q ()))
+ (cond ((null? p) ;; proper list
+ (cons 'nconc (reverse! q)))
+ ((pair? p)
+ (cond ((eq? (car p) 'unquote)
+ ;; (... . ,x)
+ (cons 'nconc
+ (nreconc q
+ (if (= d 0)
+ (cdr p)
+ (list (list list ''unquote)
+ (bq-process2 (cdr p)
+ (- d 1)))))))
+ (else
+ (loop (cdr p) (cons (bq-bracket (car p)) q)))))
+ (else
+ ;; (... . x)
+ (cons 'nconc (reverse! (cons (bq-process2 p d) q)))))))))
+
+#|
+tests
+
+> ``(,a ,,a ,b ,@b ,,@b)
+`(,a ,1 ,b ,@b (unquote 2 3))
+> `(,a ,1 ,b ,@b (unquote 2 3))
+(1 1 (2 3) 2 3 2 3)
+
+(define a 1)
+
+(bq-process2 '`(,a (unquote unquote a)) 0)
+
+(define b '(unquote a))
+(define unquote 88)
+(bq-process2 '``(,a ,,,@b) 0)
+; etc. => (1 88 1)
+
+(define b '(a a))
+(bq-process2 '``(,a ,,,@b) 0)
+; etc. => (1 1 1)
+|#
+
+;; minimal version with no optimizations, vectors, or dotted lists
+(define (bq-process0 x d)
+ (define (bq-bracket x)
+ (cond ((and (pair? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process0 (cdr x) (- d 1))))))
+ ((and (pair? x) (eq? (car x) 'unquote-splicing))
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process0 (cadr x) (- d 1))))))
+ (else (list list (bq-process0 x d)))))
+ (cond ((symbol? x) (list 'quote x))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process0 (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process0 (cdr x) (- d 1)))))
+ (else
+ (cons 'nconc (map bq-bracket x)))))
+
+#t
--- /dev/null
+++ b/femtolisp/examples/cps.lsp
@@ -1,0 +1,308 @@
+; -*- scheme -*-
+(define (begin->cps forms k)
+ (cond ((atom? forms) `(,k ,forms))
+ ((null? (cdr forms)) (cps- (car forms) k))
+ (#t (let ((_ (gensym))) ; var to bind ignored value
+ (cps- (car forms) `(lambda (,_)
+ ,(begin->cps (cdr forms) k)))))))
+
+(define-macro (lambda/cc args body)
+ `(cons 'lambda/cc (lambda ,args ,body)))
+
+; a utility used at run time to dispatch a call with or without
+; the continuation argument, depending on the function
+(define (funcall/cc f k . args)
+ (if (and (pair? f) (eq (car f) 'lambda/cc))
+ (apply (cdr f) (cons k args))
+ (k (apply f args))))
+(define *funcall/cc-names*
+ (list->vector
+ (map (lambda (i) (symbol (string 'funcall/cc- i)))
+ (iota 6))))
+(define-macro (def-funcall/cc-n args)
+ (let ((name (aref *funcall/cc-names* (length args))))
+ `(define (,name f k ,@args)
+ (if (and (pair? f) (eq (car f) 'lambda/cc))
+ ((cdr f) k ,@args)
+ (k (f ,@args))))))
+(def-funcall/cc-n ())
+(def-funcall/cc-n (a0))
+(def-funcall/cc-n (a0 a1))
+(def-funcall/cc-n (a0 a1 a2))
+(def-funcall/cc-n (a0 a1 a2 a3))
+(def-funcall/cc-n (a0 a1 a2 a3 a4))
+
+(define (rest->cps xformer form k argsyms)
+ (let ((el (car form)))
+ (if (or (atom? el) (constant? el))
+ (xformer (cdr form) k (cons el argsyms))
+ (let ((g (gensym)))
+ (cps- el `(lambda (,g)
+ ,(xformer (cdr form) k (cons g argsyms))))))))
+
+(define (make-funcall/cc head ke args)
+ (let ((n (length args)))
+ (if (< n 6)
+ `(,(aref *funcall/cc-names* n) ,head ,ke ,@args)
+ `(funcall/cc ,head ,ke ,@args))))
+
+; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
+(define (app->cps form k argsyms)
+ (cond ((atom? form)
+ (let ((r (reverse argsyms)))
+ (make-funcall/cc (car r) k (cdr r))))
+ (#t (rest->cps app->cps form k argsyms))))
+
+; (+ x) => (cps- x `(lambda (X) (,k (+ X))))
+(define (builtincall->cps form k)
+ (prim->cps (cdr form) k (list (car form))))
+(define (prim->cps form k argsyms)
+ (cond ((atom? form) `(,k ,(reverse argsyms)))
+ (#t (rest->cps prim->cps form k argsyms))))
+
+(define *top-k* (gensym))
+(set-top-level-value! *top-k* identity)
+
+(define (cps form)
+ (η-reduce
+ (β-reduce
+ (expand
+ (cps- (expand form) *top-k*)))))
+(define (cps- form k)
+ (let ((g (gensym)))
+ (cond ((or (atom? form) (constant? form))
+ `(,k ,form))
+
+ ((eq (car form) 'lambda)
+ `(,k (lambda/cc ,(cons g (cadr form)) ,(cps- (caddr form) g))))
+
+ ((eq (car form) 'begin)
+ (begin->cps (cdr form) k))
+
+ ((eq (car form) 'if)
+ (let ((test (cadr form))
+ (then (caddr form))
+ (else (cadddr form)))
+ (if (atom? k)
+ (cps- test `(lambda (,g)
+ (if ,g
+ ,(cps- then k)
+ ,(cps- else k))))
+ `(let ((,g ,k))
+ ,(cps- form g)))))
+
+ ((eq (car form) 'and)
+ (cond ((atom? (cdr form)) `(,k #t))
+ ((atom? (cddr form)) (cps- (cadr form) k))
+ (#t
+ (if (atom? k)
+ (cps- (cadr form)
+ `(lambda (,g)
+ (if ,g ,(cps- `(and ,@(cddr form)) k)
+ (,k ,g))))
+ `(let ((,g ,k))
+ ,(cps- form g))))))
+
+ ((eq (car form) 'or)
+ (cond ((atom? (cdr form)) `(,k #f))
+ ((atom? (cddr form)) (cps- (cadr form) k))
+ (#t
+ (if (atom? k)
+ (cps- (cadr form)
+ `(lambda (,g)
+ (if ,g (,k ,g)
+ ,(cps- `(or ,@(cddr form)) k))))
+ `(let ((,g ,k))
+ ,(cps- form g))))))
+
+ ((eq (car form) 'while)
+ (let ((test (cadr form))
+ (body (caddr form))
+ (lastval (gensym)))
+ (cps- (expand
+ `(let ((,lastval #f))
+ ((label ,g (lambda ()
+ (if ,test
+ (begin (set! ,lastval ,body)
+ (,g))
+ ,lastval))))))
+ k)))
+
+ ((eq (car form) 'set!)
+ (let ((var (cadr form))
+ (E (caddr form)))
+ (cps- E `(lambda (,g) (,k (set! ,var ,g))))))
+
+ ((eq (car form) 'reset)
+ `(,k ,(cps- (cadr form) *top-k*)))
+
+ ((eq (car form) 'shift)
+ (let ((v (cadr form))
+ (E (caddr form))
+ (val (gensym)))
+ `(let ((,v (lambda/cc (,g ,val) (,g (,k ,val)))))
+ ,(cps- E *top-k*))))
+
+ ((eq (car form) 'without-delimited-continuations)
+ `(,k ,(cadr form)))
+
+ ((and (constant? (car form))
+ (builtin? (eval (car form))))
+ (builtincall->cps form k))
+
+ ; ((lambda (...) body) ...)
+ ((and (pair? (car form))
+ (eq (caar form) 'lambda))
+ (let ((largs (cadr (car form)))
+ (lbody (caddr (car form))))
+ (cond ((null? largs) ; ((lambda () body))
+ (cps- lbody k))
+ ((symbol? largs) ; ((lambda x body) args...)
+ (cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k))
+ (#t
+ (cps- (cadr form) `(lambda (,(car largs))
+ ,(cps- `((lambda ,(cdr largs) ,lbody)
+ ,@(cddr form))
+ k)))))))
+
+ (#t
+ (app->cps form k ())))))
+
+; (lambda (args...) (f args...)) => f
+; but only for constant, builtin f
+(define (η-reduce form)
+ (cond ((or (atom? form) (constant? form)) form)
+ ((and (eq (car form) 'lambda)
+ (let ((body (caddr form))
+ (args (cadr form)))
+ (and (pair? body)
+ (equal? (cdr body) args)
+ (constant? (car (caddr form))))))
+ (car (caddr form)))
+ (#t (map η-reduce form))))
+
+(define (contains x form)
+ (or (eq form x)
+ (any (lambda (p) (contains x p)) form)))
+
+(define (β-reduce form)
+ (if (or (atom? form) (constant? form))
+ form
+ (β-reduce- (map β-reduce form))))
+
+(define (β-reduce- form)
+ ; ((lambda (f) (f arg)) X) => (X arg)
+ (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)
+ (eq (car body) (car args))
+ (not (eq (cadr body) (car args)))
+ (symbol? (cadr body)))))
+ `(,(cadr form)
+ ,(cadr (caddr (car form)))))
+
+ ; (identity x) => x
+ ((eq (car form) *top-k*)
+ (cadr form))
+
+ ; uncurry:
+ ; ((lambda (p1) ((lambda (args...) body) exprs...)) s) =>
+ ; ((lambda (p1 args...) body) s exprs...)
+ ; where exprs... doesn't contain p1
+ ((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)
+ (pair? body)
+ (pair? (car body))
+ (eq (caar body) 'lambda)
+ (let ((innerargs (cadr (car body)))
+ (innerbody (caddr (car body)))
+ (params (cdr body)))
+ (and (not (contains (car args) params))
+ `((lambda ,(cons (car args) innerargs)
+ ,innerbody)
+ ,s
+ ,@params)))))))
+
+ (#t form)))
+
+(define-macro (with-delimited-continuations . code)
+ (cps `((lambda () ,@code))))
+
+(define-macro (define-generator form . body)
+ (let ((ko (gensym))
+ (cur (gensym))
+ (name (car form))
+ (args (cdr form)))
+ `(define (,name ,@args)
+ (let ((,ko #f)
+ (,cur #f))
+ (lambda ()
+ (with-delimited-continuations
+ (if ,ko (,ko ,cur)
+ (reset
+ (let ((yield
+ (lambda (v)
+ (shift yk
+ (begin (set! ,ko yk)
+ (set! ,cur v))))))
+ ,@body)))))))))
+
+; a test case
+(define-generator (range-iterator lo hi)
+ ((label loop
+ (lambda (i)
+ (if (< hi i)
+ 'done
+ (begin (yield i)
+ (loop (+ 1 i))))))
+ lo))
+
+; example from Chung-chieh Shan's paper
+(assert (equal?
+ (with-delimited-continuations
+ (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
+ '(a 1 b b c)))
+
+#t
+
+#|
+todo:
+* tag lambdas that accept continuation arguments, compile computed
+ calls to calls to funcall/cc that does the right thing for both
+ cc-lambdas and normal lambdas
+
+* handle dotted arglists in lambda
+
+- optimize constant functions, e.g. (funcall/cc-0 #:g65 (lambda (#:g58) 'done))
+
+- implement CPS version of apply
+
+- use fewer gensyms
+
+ here's an alternate way to transform a while loop:
+
+ (let ((x 0))
+ (while (< x 10)
+ (begin (print x) (set! x (+ 1 x)))))
+ =>
+ (let ((x 0))
+ (reset
+ (let ((l #f))
+ (let ((k (shift k (k k))))
+ (if (< x 10)
+ (begin (set! l (begin (print x)
+ (set! x (+ 1 x))))
+ (k k))
+ l)))))
+|#
--- /dev/null
+++ b/femtolisp/examples/rule30.lsp
@@ -1,0 +1,25 @@
+; -*- 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 (bin-draw s)
+ (string.map (lambda (c) (case c
+ (#\1 #\#)
+ (#\0 #\ )
+ (else c)))
+ s))
+
+(for-each (lambda (n)
+ (begin
+ (princ (bin-draw (string.lpad (number->string n 2) 63 #\0)))
+ (newline)))
+ (nestlist rule30-step (uint64 0x0000000080000000) 32))
--- a/femtolisp/perf.lsp
+++ /dev/null
@@ -1,37 +1,0 @@
-(load "test.lsp")
-
-(princ "colorgraph: ")
-(load "tcolor.lsp")
-
-(princ "fib(34): ")
-(assert (equal? (time (fib 34)) 5702887))
-(princ "yfib(32): ")
-(assert (equal? (time (yfib 32)) 2178309))
-
-(princ "sort: ")
-(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
-(time (simple-sort r))
-
-(princ "expand: ")
-(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
-
-(define (my-append . lsts)
- (cond ((null? lsts) ())
- ((null? (cdr lsts)) (car lsts))
- (else (letrec ((append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d))))))
- (append2 (car lsts) (apply my-append (cdr lsts)))))))
-
-(princ "append: ")
-(set! L (map-int (lambda (x) (map-int identity 20)) 20))
-(time (dotimes (n 1000) (apply my-append L)))
-
-(path.cwd "ast")
-(princ "p-lambda: ")
-(load "rpasses.lsp")
-(define *input* (load "datetimeR.lsp"))
-(time (set! *output* (compile-ish *input*)))
-(assert (equal? *output* (load "rpasses-out.lsp")))
-(path.cwd "..")
--- a/femtolisp/rule30.lsp
+++ /dev/null
@@ -1,25 +1,0 @@
-; -*- 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 (bin-draw s)
- (string.map (lambda (c) (case c
- (#\1 #\#)
- (#\0 #\ )
- (else c)))
- s))
-
-(for-each (lambda (n)
- (begin
- (princ (bin-draw (string.lpad (number->string n 2) 63 #\0)))
- (newline)))
- (nestlist rule30-step (uint64 0x0000000080000000) 32))
--- a/femtolisp/site/doc
+++ /dev/null
@@ -1,62 +1,0 @@
-1. Syntax
-
-symbols
-numbers
-conses and vectors
-comments
-special prefix tokens: ' ` , ,@ ,.
-other read macros: #. #' #\ #< #n= #n# #: #ctor
-builtins
-
-2. Data and execution models
-
-3. Primitive functions
-
-eq atom not set prog1 progn
-symbolp numberp builtinp consp vectorp boundp
-+ - * / <
-apply eval
-
-4. Special forms
-
-quote if lambda macro while label cond and or
-
-5. Data structures
-
-cons car cdr rplaca rplacd list
-alloc vector aref aset length
-
-6. Other functions
-
-read, print, princ, load, exit
-equal, compare
-gensym
-
-7. Exceptions
-
-trycatch raise
-
-8. Cvalues
-
-introduction
-type representations
-constructors
-access
-memory management concerns
-ccall
-
-
-If deliberate 50% heap utilization seems wasteful, consider:
-
-- malloc has per-object overhead. for small allocations you might use
- much more space than you think.
-- any non-moving memory manager (whether malloc or a collector) can
- waste arbitrary amounts of memory through fragmentation.
-
-With a copying collector, you agree to give up 50% of your memory
-up front, in exchange for significant benefits:
-
-- really fast allocation
-- heap compaction, improving locality and possibly speeding up computation
-- collector performance O(1) in number of dead objects, essential for
- maximal performance on generational workloads
--- a/femtolisp/site/doc.html
+++ /dev/null
@@ -1,428 +1,0 @@
-<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
- "http://www.w3.org/TR/html4/loose.dtd">
-<html>
-<head>
-<meta http-equiv="Content-Type" content="text/html;charset=utf-8" >
-<title>femtoLisp</title>
-</head>
-<body bgcolor="#fcfcfc"> <!-"#fcfcc8">
-<img src="flbanner.jpg">
-
-<table border=0 width="100%" cellpadding=0 cellspacing=0>
-<tr><td bgcolor="#2d3f5f" height=4></table>
-
-<h1>0. Argument</h1>
-This Lisp has the following characteristics and goals:
-
-<ul>
-<li>Lisp-1 evaluation rule (ala Scheme)
-<li>Self-evaluating lambda (i.e. <tt>'(lambda (x) x)</tt> is callable)
-<li>Full Common Lisp-style macros
-<li>Dotted lambda lists for rest arguments (ala Scheme)
-<li>Symbols have one binding
-<li>Builtin functions are constants
-<li><em>All</em> values are printable and readable
-<li>Case-sensitive symbol names
-<li>Only the minimal core built-in (i.e. written in C), but
- enough to provide a practical level of performance
-<li>Very short (but not necessarily simple...) implementation
-<li>Generally use Common Lisp operator names
-<li>Nothing excessively weird or fancy
-</ul>
-
-<h1>1. Syntax</h1>
-<h2>1.1. Symbols</h2>
-Any character string can be a symbol name, including the empty string. In
-general, text between whitespace is read as a symbol except in the following
-cases:
-<ul>
-<li>The text begins with <tt>#</tt>
-<li>The text consists of a single period <tt>.</tt>
-<li>The text contains one of the special characters <tt>()[]';`,\|</tt>
-<li>The text is a valid number
-<li>The text is empty
-</ul>
-In these cases the symbol can be written by surrounding it with <tt>| |</tt>
-characters, or by escaping individual characters within the symbol using
-backslash <tt>\</tt>. Note that <tt>|</tt> and <tt>\</tt> must always be
-preceded with a backslash when writing a symbol name.
-
-<h2>1.2. Numbers</h2>
-
-A number consists of an optional + or - sign followed by one of the following
-sequences:
-<ul>
-<li><tt>NNN...</tt> where N is a decimal digit
-<li><tt>0xNNN...</tt> where N is a hexadecimal digit
-<li><tt>0NNN...</tt> where N is an octal digit
-</ul>
-femtoLisp provides 30-bit integers, and it is an error to write a constant
-less than -2<sup>29</sup> or greater than 2<sup>29</sup>-1.
-
-<h2>1.3. Conses and vectors</h2>
-
-The text <tt>(a b c)</tt> parses to the structure
-<tt>(cons a (cons b (cons c nil)))</tt> where a, b, and c are arbitrary
-expressions.
-<p>
-The text <tt>(a . b)</tt> parses to the structure
-<tt>(cons a b)</tt> where a and b are arbitrary expressions.
-<p>
-The text <tt>()</tt> reads as the symbol <tt>nil</tt>.
-<p>
-The text <tt>[a b c]</tt> parses to a vector of expressions a, b, and c.
-The syntax <tt>#(a b c)</tt> has the same meaning.
-
-
-<h2>1.4. Comments</h2>
-
-Text between a semicolon <tt>;</tt> and the next end-of-line is skipped.
-Text between <tt>#|</tt> and <tt>|#</tt> is also skipped.
-
-<h2>1.5. Prefix tokens</h2>
-
-There are five special prefix tokens which parse as follows:<p>
-<tt>'a</tt> is equivalent to <tt>(quote a)</tt>.<br>
-<tt>`a</tt> is equivalent to <tt>(backquote a)</tt>.<br>
-<tt>,a</tt> is equivalent to <tt>(*comma* a)</tt>.<br>
-<tt>,@a</tt> is equivalent to <tt>(*comma-at* a)</tt>.<br>
-<tt>,.a</tt> is equivalent to <tt>(*comma-dot* a)</tt>.
-
-
-<h2>1.6. Other read macros</h2>
-
-femtoLisp provides a few "read macros" that let you accomplish interesting
-tricks for textually representing data structures.
-
-<table border=1>
-<tr>
-<td>sequence<td>meaning
-<tr>
-<td><tt>#.e</tt><td>evaluate expression <tt>e</tt> and behave as if e's
- value had been written in place of e
-<tr>
-<td><tt>#\c</tt><td><tt>c</tt> is a character; read as its Unicode value
-<tr>
-<td><tt>#n=e</tt><td>read <tt>e</tt> and label it as <tt>n</tt>, where n
- is a decimal number
-<tr>
-<td><tt>#n#</tt><td>read as the identically-same value previously labeled
- <tt>n</tt>
-<tr>
-<td><tt>#:gNNN or #:NNN</tt><td>read a gensym. NNN is a hexadecimal
- constant. future occurrences of the same <tt>#:</tt> sequence will read to
- the identically-same gensym
-<tr>
-<td><tt>#sym(...)</tt><td>reads to the result of evaluating
- <tt>(apply sym '(...))</tt>
-<tr>
-<td><tt>#<</tt><td>triggers an error
-<tr>
-<td><tt>#'</tt><td>ignored; provided for compatibility
-<tr>
-<td><tt>#!</tt><td>single-line comment, for script execution support
-<tr>
-<td><tt>"str"</tt><td>UTF-8 character string; may contain newlines.
- <tt>\</tt> is the escape character. All C escape sequences are supported, plus
- <tt>\u</tt> and <tt>\U</tt> for unicode values.
-</table>
-When a read macro involves persistent state (e.g. label assignments), that
-state is valid only within the closest enclosing call to <tt>read</tt>.
-
-
-<h2>1.7. Builtins</h2>
-
-Builtin functions are represented as opaque constants. Every builtin
-function is the value of some constant symbol, so the builtin <tt>eq</tt>,
-for example, can be written as <tt>#.eq</tt> ("the value of symbol eq").-Note that <tt>eq</tt> itself is still an ordinary symbol, except that its
-value cannot be changed.
-<p>
-
-<table border=0 width="100%" cellpadding=0 cellspacing=0>
-<tr><td bgcolor="#2d3f5f" height=4></table>
-
-
-<h1>2. Data and execution models</h1>
-
-
-
-
-<table border=0 width="100%" cellpadding=0 cellspacing=0>
-<tr><td bgcolor="#2d3f5f" height=4></table>
-
-
-<h1>3. Primitive functions</h1>
-
-
-eq atom not set prog1 progn
-symbolp numberp builtinp consp vectorp boundp
-+ - * / <
-apply eval
-
-
-<table border=0 width="100%" cellpadding=0 cellspacing=0>
-<tr><td bgcolor="#2d3f5f" height=4></table>
-
-<h1>4. Special forms</h1>
-
-quote if lambda macro while label cond and or
-
-
-<table border=0 width="100%" cellpadding=0 cellspacing=0>
-<tr><td bgcolor="#2d3f5f" height=4></table>
-
-<h1>5. Data structures</h1>
-
-cons car cdr rplaca rplacd list
-alloc vector aref aset length
-
-
-<table border=0 width="100%" cellpadding=0 cellspacing=0>
-<tr><td bgcolor="#2d3f5f" height=4></table>
-
-<h1>6. Other functions</h1>
-
-read print princ load exit
-equal compare
-gensym
-
-
-<table border=0 width="100%" cellpadding=0 cellspacing=0>
-<tr><td bgcolor="#2d3f5f" height=4></table>
-
-<h1>7. Exceptions</h1>
-
-trycatch raise
-
-
-<table border=0 width="100%" cellpadding=0 cellspacing=0>
-<tr><td bgcolor="#2d3f5f" height=4></table>
-
-<h1>8. Cvalues</h1>
-
-<h2>8.1. Introduction</h2>
-
-femtoLisp allows you to use the full range of C data types on
-dynamically-typed Lisp values. The motivation for this feature is that
-useful
-interpreters must provide a large library of routines in C for dealing
-with "real world" data like text and packed numeric arrays, and I would
-rather not write yet another such library. Instead, all the
-required data representations and primitives are provided so that such
-features could be implemented in, or at least described in, Lisp.
-<p>
-The cvalues capability makes it easier to call C from Lisp by providing
-ways to construct whatever arguments your C routines might require, and ways
-to decipher whatever values your C routines might return. Here are some
-things you can do with cvalues:
-<ul>
-<li>Call native C functions from Lisp without wrappers
-<li>Wrap C functions in pure Lisp, automatically inheriting some degree
- of type safety
-<li>Use Lisp functions as callbacks from C code
-<li>Use the Lisp garbage collector to reclaim malloc'd storage
-<li>Annotate C pointers with size information for bounds checking or
- serialization
-<li>Attach symbolic type information to a C data structure, allowing it to
- inherit Lisp services such as printing a readable representation
-<li>Add datatypes like strings to Lisp
-<li>Use more efficient represenations for your Lisp programs' data
-</ul>
-<p>
-femtoLisp's "cvalues" is inspired in part by Python's "ctypes" package.
-Lisp doesn't really have first-class types the way Python does, but it does
-have values, hence my version is called "cvalues".
-
-<h2>8.2. Type representations</h2>
-
-The core of cvalues is a language for describing C data types as
-symbolic expressions:
-
-<ul>
-<li>Primitive types are symbols <tt>int8, uint8, int16, uint16, int32, uint32,
-int64, uint64, char, wchar, long, ulong, float, double, void</tt>
-<li>Arrays <tt>(array TYPE SIZE)</tt>, where TYPE is another C type and
-SIZE is either a Lisp number or a C ulong. SIZE can be omitted to
-represent incomplete C array types like "int a[]". As in C, the size may
-only be omitted for the top level of a nested array; all array
-<em>element</em> types
-must have explicit sizes. Examples:
-<ul>
- <tt>int a[][2][3]</tt> is <tt>(array (array (array int32 3) 2))</tt><br>
- <tt>int a[4][]</tt> would be <tt>(array (array int32) 4)</tt>, but this is
- invalid.
-</ul>
-<li>Pointer <tt>(pointer TYPE)</tt>
-<li>Struct <tt>(struct ((NAME TYPE) (NAME TYPE) ...))</tt>
-<li>Union <tt>(union ((NAME TYPE) (NAME TYPE) ...))</tt>
-<li>Enum <tt>(enum (NAME NAME ...))</tt>
-<li>Function <tt>(c-function RET-TYPE (ARG-TYPE ARG-TYPE ...))</tt>
-</ul>
-
-A cvalue can be constructed using <tt>(c-value TYPE arg)</tt>, where
-<tt>arg</tt> is some Lisp value. The system will try to convert the Lisp
-value to the specified type. In many cases this will work better if some
-components of the provided Lisp value are themselves cvalues.
-
-<p>
-Note the function type is called "c-function" to avoid confusion, since
-functions are such a prevalent concept in Lisp.
-
-<p>
-The function <tt>sizeof</tt> returns the size (in bytes) of a cvalue or a
-c type. Every cvalue has a size, but incomplete types will cause
-<tt>sizeof</tt> to raise an error. The function <tt>typeof</tt> returns
-the type of a cvalue.
-
-<p>
-You are probably wondering how 32- and 64-bit integers are constructed from
-femtoLisp's 30-bit integers. The answer is that larger integers are
-constructed from multiple Lisp numbers 16 bits at a time, in big-endian
-fashion. In fact, the larger numeric types are the only cvalues
-types whose constructors accept multiple arguments. Examples:
-<ul>
-<pre>
-(c-value 'int32 0xdead 0xbeef) ; make 0xdeadbeef
-(c-value 'uint64 0x1001 0x8000 0xffff) ; make 0x000010018000ffff
-</pre>
-</ul>
-As you can see, missing zeros are padded in from the left.
-
-
-<h2>8.3. Constructors</h2>
-
-For convenience, a specialized constructor is provided for each
-class of C type (primitives, pointer, array, struct, union, enum,
-and c-function).
-For example:
-<ul>
-<pre>
-(uint32 0xcafe 0xd00d)
-(int32 -4)
-(char #\w)
-(array 'int8 [1 1 2 3 5 8])
-</pre>
-</ul>
-
-These forms can be slightly less efficient than <tt>(c-value ...)</tt>
-because in many cases they will allocate a new type for the new value.
-For example, the fourth expression must create the type
-<tt>(array int8 6)</tt>.
-
-<p>
-Notice that calls to these constructors strongly resemble
-the types of the values they create. This relationship can be expressed
-formally as follows:
-
-<pre>
-(define (c-allocate type)
- (if (atom type)
- (apply (eval type) ())
- (apply (eval (car type)) (cdr type))))
-</pre>
-
-This function produces an instance of the given type by
-invoking the appropriate constructor. Primitive types (whose representations
-are symbols) can be constructed with zero arguments. For other types,
-the only required arguments are those present in the type representation.
-Any arguments after those are initializers. Using
-<tt>(cdr type)</tt> as the argument list provides only required arguments,
-so the value you get will not be initialized.
-
-<p>
-The builtin <tt>c-value</tt> function is similar to this one, except that it
-lets you pass initializers.
-
-<p>
-Cvalue constructors are generally permissive; they do the best they
-can with whatever you pass in. For example:
-
-<ul>
-<pre>
-(c-value '(array int8 1)) ; ok, full type provided
-(c-value '(array int8)) ; error, no size information
-(c-value '(array int8) [0 1]) ; ok, size implied by initializer
-</pre>
-</ul>
-
-<p>
-ccopy, c2lisp
-
-<h2>8.4. Pointers, arrays, and strings</h2>
-
-Pointer types are provided for completeness and C interoperability, but
-they should not generally be used from Lisp. femtoLisp doesn't know
-anything about a pointer except the raw address and the (alleged) type of the
-value it points to. Arrays are much more useful. They behave like references
-as in C, but femtoLisp tracks their sizes and performs bounds checking.
-
-<p>
-Arrays are used to allocate strings. All strings share
-the incomplete array type <tt>(array char)</tt>:
-
-<pre>
-> (c-value '(array char) [#\h #\e #\l #\l #\o])
-"hello"
-
-> (sizeof that)
-5
-</pre>
-
-<tt>sizeof</tt> reveals that the size is known even though it is not
-reflected in the type (as is always the case with incomplete array types).
-
-<p>
-Since femtoLisp tracks the sizes of all values, there is no need for NUL
-terminators. Strings are just arrays of bytes, and may contain zero bytes
-throughout. However, C functions require zero-terminated strings. To
-solve this problem, femtoLisp allocates magic strings that actually have
-space for one more byte than they appear to. The hidden extra byte is
-always zero. This guarantees that a C function operating on the string
-will never overrun its allocated space.
-
-<p>
-Such magic strings are produced by double-quoted string literals, and by
-any explicit string-constructing function (such as <tt>string</tt>).
-
-<p>
-Unfortunately you still need to be careful, because it is possible to
-allocate a non-magic character array with no terminator. The "hello"
-string above is an example of this, since it was constructed from an
-explicit vector of characters.
-Such an array would cause problems if passed to a function expecting a
-C string.
-
-<p>
-deref
-
-<h2>8.5. Access</h2>
-
-cref,cset,byteref,byteset,ccopy
-
-<h2>8.6. Memory management concerns</h2>
-
-autorelease
-
-
-<h2>8.7. Guest functions</h2>
-
-Functions written in C but designed to operate on Lisp values are
-known here as "guest functions". Although they are foreign, they live in
-Lisp's house and so live by its rules. Guest functions are what you
-use to write interpreter extensions, for example to implement a function
-like <tt>assoc</tt> in C for performance.
-
-<p>
-Guest functions must have a particular signature:
-<pre>
-value_t func(value_t *args, uint32_t nargs);
-</pre>
-Guest functions must also be aware of the femtoLisp API and garbage
-collector.
-
-
-<h2>8.8. Native functions</h2>
-
-</body>
-</html>
binary files a/femtolisp/site/flbanner.jpg /dev/null differ
binary files a/femtolisp/site/flbanner.xcf /dev/null differ
binary files a/femtolisp/site/flbanner2.jpg /dev/null differ
--- a/femtolisp/site/index.html
+++ /dev/null
@@ -1,206 +1,0 @@
-<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
- "http://www.w3.org/TR/html4/loose.dtd">
-<html>
-<head>
-<meta http-equiv="Content-Type" content="text/html;charset=utf-8" >
-<title>femtoLisp</title>
-</head>
-<body>
-<h1>femtoLisp</h1>
-<hr>
-femtoLisp is an elegant Lisp implementation. Its goal is to be a
-reasonably efficient and capable interpreter with the shortest, simplest
-code possible. As its name implies, it is small (10<sup>-15</sup>).
-Right now it is just 1000 lines of C (give or take). It would make a great
-teaching example, or a useful system anywhere a very small Lisp is wanted.
-It is also a useful basis for developing other interpreters or related
-languages.
-
-
-<h2>The language implemented</h2>
-
-femtoLisp tries to be a generic, simple Lisp dialect, influenced by McCarthy's
-original.
-
-<ul>
-<li>Types: cons, symbol, 30-bit integer, builtin function
-<li>Self-evaluating lambda, macro, and label forms
-<li>Full Common Lisp-style macros
-<li>Case-sensitive symbol names
-<li>Scheme-style evaluation rule where any expression may appear in head
- position as long as it evaluates to a callable
-<li>Scheme-style formal argument lists (dotted lists for varargs)
-<li>Transparent closure representation <tt>(lambda args body . env)</tt>
-<li>A lambda body may contain only one form. Use explicit <tt>progn</tt> for
- multiple forms. Included macros, however, allow <tt>defun</tt>,
- <tt>let</tt>, etc. to accept multiple body forms.
-<li>Builtin function names are constants and cannot be redefined.
-<li>Symbols have one binding, as in Scheme.
-</ul>
-<b>Builtin special forms:</b><br>
-<tt>quote, cond, if, and, or, lambda, macro, label, while, progn, prog1</tt>
-<p>
-<b>Builtin functions:</b><br>
-<tt>eq, atom, not, symbolp, numberp, boundp, cons, car, cdr,
- read, eval, print, load, set,
- +, -, *, /, <, apply, rplaca, rplacd</tt>
-<p>
-<b>Included library functions and macros:</b><br>
-<tt>
-setq, setf, defmacro, defun, define, let, let*, labels, dotimes,
-macroexpand-1, macroexpand, backquote,
-
-null, consp, builtinp, self-evaluating-p, listp, eql, equal, every, any,
-when, unless,
-
-=, !=, >, <=, >=, compare, mod, abs, identity,
-
-list, list*, length, last, nthcdr, lastcdr, list-ref, reverse, nreverse,
-assoc, member, append, nconc, copy-list, copy-tree, revappend, nreconc,
-
-mapcar, filter, reduce, map-int,
-
-symbol-plist, set-symbol-plist, put, get
-</tt>
-<p>
-<a href="system.lsp">system.lsp</a>
-
-
-<h2>The implementation</h2>
-
-<ul>
-<li>Compacting copying garbage collector (<tt>O(1)</tt> in number of dead
- objects)
-<li>Tagged pointers for efficient type checking and fast integers
-<li>Tail-recursive evaluator (tail calls use no stack space)
-<li>Minimally-consing <tt>apply</tt>
-<li>Interactive and script execution modes
-</ul>
-<p>
-<a href="lisp.c">lisp.c</a>
-
-
-<h2>femtoLisp2</h2>
-
-This version includes robust reading and printing capabilities for
-circular structures and escaped symbol names. It adds read and print support
-for the Common Lisp read-macros <tt>#., #n#,</tt> and <tt>#n=</tt>.
-This allows builtins to be printed in a readable fashion as e.g.
-"<tt>#.eq</tt>".
-<p>
-The net result is that the interpreter achieves a highly satisfying property
-of closure under I/O. In other words, every representable Lisp value can be
-read and printed.
-<p>
-The traditional builtin <tt>label</tt> provides a purely-functional,
-non-circular way
-to write an anonymous recursive function. In femtoLisp2 you can
-achieve the same effect "manually" using nothing more than the reader:
-<br>
-<tt>#0=(lambda (x) (if (<= x 0) 1 (* x (#0# (- x 1)))))</tt>
-<p>
-femtoLisp2 has the following extra features and optimizations:
-<ul>
-<li> builtin functions <tt>error, exit,</tt> and <tt>princ</tt>
-<li> read support for backquote expressions
-<li> delayed environment consing
-<li> collective allocation of cons chains
-</ul>
-Those two optimizations are a Big Deal.
-<p>
-<a href="lisp2.c">lisp2.c</a> (uses <a href="flutils.c">flutils.c</a>)
-
-
-<h2>Performance</h2>
-
-femtoLisp's performance is surprising. It is faster than most
-interpreters, and it is usually within a factor of 2-5 of compiled CLISP.
-
-<table border=1>
-<tr>
-<td colspan=3><center><b>solve 5 queens problem 100x</b></center></td>
-<tr>
-<td> <td>interpreted<td>compiled
-<tr>
-<td>CLISP <td>4.02 sec <td>0.68 sec
-<tr>
-<td>femtoLisp2<td>2.62 sec <td>2.03 sec**
-<tr>
-<td>femtoLisp <td>6.02 sec <td>5.64 sec**
-<tr>
-
-<td colspan=3><center><b>recursive fib(34)</b></center></td>
-<tr>
-<td> <td>interpreted<td>compiled
-<tr>
-<td>CLISP <td>23.12 sec <td>4.04 sec
-<tr>
-<td>femtoLisp2<td>4.71 sec <td>n/a
-<tr>
-<td>femtoLisp <td>7.25 sec <td>n/a
-<tr>
-
-</table>
-** femtoLisp is not a compiler; in this context "compiled" means macros
-were pre-expanded.
-
-
-<h2>"Installation"</h2>
-
-Here is a <a href="Makefile">Makefile</a>. Type <tt>make</tt> to build
-femtoLisp, <tt>make NAME=lisp2</tt> to build femtoLisp2.
-
-
-<h2>Tail recursion</h2>
-The femtoLisp evaluator is tail-recursive, following the idea in
-<a href="http://library.readscheme.org/servlets/cite.ss?pattern=Ste-76b">
-Lambda: The Ultimate Declarative</a> (should be required reading
-for all schoolchildren).
-<p>
-The femtoLisp source provides a simple concrete example showing why a function
-call is best viewed as a "renaming plus goto" rather than as a set of stack
-operations.
-<p>
-Here is the non-tail-recursive evaluator code to evaluate the body of a
-lambda (function), from <a href="lisp-nontail.c">lisp-nontail.c</a>:
-<pre>
- PUSH(*lenv); // preserve environment on stack
- lenv = &Stack[SP-1];
- v = eval(*body, lenv);
- POP();
- return v;
-</pre>
-(Note that because of the copying garbage collector, values are referenced
-through relocatable handles.)
-<p>
-Superficially, the call to <tt>eval</tt> is not a tail call, because work
-remains after it returns—namely, popping the environment off the stack.
-In other words, the control stack must be saved and restored to allow us to
-eventually restore the environment stack. However, restoring the environment
-stack is the <i>only</i> work to be done. Yet after this point the old
-environment is not used! So restoring the environment stack isn't
-necessary, therefore restoring the control stack isn't either.
-<p>
-This perspective makes proper tail recursion seem like more than an
-alternate design or optimization. It seems more correct.
-<p>
-Here is the corrected, tail-recursive version of the code:
-<pre>
- SP = saveSP; // restore stack completely
- e = *body; // reassign arguments
- *penv = *lenv;
- goto eval_top;
-</pre>
-<tt>penv</tt> is a pointer to the old environment, which we overwrite.
-(Notice that the variable <tt>penv</tt> does not even appear in the first code
-example.)
-So where is the environment saved and restored, if not here? The answer
-is that the burden is shifted to the caller; a caller to <tt>eval</tt> must
-expect that its environment might be overwritten, and take steps to save it
-if it will be needed further after the call. In practice, this means
-the environment is saved and restored around the evaluation of
-arguments, rather than around function applications. Hence <tt>(f x)</tt>
-might be a tail call to <tt>f</tt>, but <tt>(+ y (f x))</tt> is not.
-
-</body>
-</html>
--- a/femtolisp/tcolor.lsp
+++ /dev/null
@@ -1,16 +1,0 @@
-; -*- scheme -*-
-; color for performance
-
-(load "color.lsp")
-
-; 100x color 5 queens
-(define Q (generate-5x5-pairs))
-(define (ct)
- (set! C (color-pairs Q '(a b c d e)))
- (dotimes (n 99) (color-pairs Q '(a b c d e))))
-(time (ct))
-(assert (equal? C
- '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))))
--- a/femtolisp/test.lsp
+++ /dev/null
@@ -1,294 +1,0 @@
-; -*- scheme -*-
-
-; make label self-evaluating, but evaluating the lambda in the process
-;(defmacro labl (name f)
-; (list list ''labl (list 'quote name) f))
-
-(define-macro (labl name f)
- `(let (,name) (set! ,name ,f)))
-
-;(define (reverse lst)
-; ((label rev-help (lambda (lst result)
-; (if (null? lst) result
-; (rev-help (cdr lst) (cons (car lst) result)))))
-; lst ()))
-
-(define (append- . lsts)
- ((label append-h
- (lambda (lsts)
- (cond ((null? lsts) ())
- ((null? (cdr lsts)) (car lsts))
- (#t ((label append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d)))))
- (car lsts) (append-h (cdr lsts)))))))
- lsts))
-
-;(princ 'Hello '| | 'world! "\n")
-;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
-(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-;(princ (time (fib 34)) "\n")
-;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
-;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
-;(dotimes (i 80000) (list 1 2 3 4 5))
-;(set! a (map-int identity 10000))
-;(dotimes (i 200) (rfoldl cons () a))
-
-#|
-(define-macro (dotimes var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- `(let ((,v 0))
- (while (< ,v ,cnt)
- (prog1
- ,(cons 'begin body)
- (set! ,v (+ ,v 1)))))))
-
-(define (map-int f n)
- (if (<= n 0)
- ()
- (let ((first (cons (f 0) ())))
- ((label map-int-
- (lambda (acc i n)
- (if (= i n)
- first
- (begin (set-cdr! acc (cons (f i) ()))
- (map-int- (cdr acc) (+ i 1) n)))))
- first 1 n))))
-|#
-
-(define-macro (labl name fn)
- `((lambda (,name) (set! ,name ,fn)) ()))
-
-(define (square x) (* x x))
-(define (expt b p)
- (cond ((= p 0) 1)
- ((= b 0) 0)
- ((even? p) (square (expt b (div0 p 2))))
- (#t (* b (expt b (- p 1))))))
-
-(define (gcd a b)
- (cond ((= a 0) b)
- ((= b 0) a)
- ((< a b) (gcd a (- b a)))
- (#t (gcd b (- a b)))))
-
-; like eval-when-compile
-(define-macro (literal expr)
- (let ((v (eval expr)))
- (if (self-evaluating? v) v (list quote v))))
-
-(define (cardepth l)
- (if (atom? l) 0
- (+ 1 (cardepth (car l)))))
-
-(define (nestlist f zero n)
- (if (<= n 0) ()
- (cons zero (nestlist f (f zero) (- n 1)))))
-
-(define (mapl f . lsts)
- ((label mapl-
- (lambda (lsts)
- (if (null? (car lsts)) ()
- (begin (apply f lsts) (mapl- (map cdr lsts))))))
- lsts))
-
-; test to see if a symbol begins with :
-(define (keywordp s)
- (and (>= s '|:|) (<= s '|:~|)))
-
-; swap the cars and cdrs of every cons in a structure
-(define (swapad c)
- (if (atom? c) c
- (set-cdr! c (K (swapad (car c))
- (set-car! c (swapad (cdr c)))))))
-
-(define (without x l)
- (filter (lambda (e) (not (eq e x))) l))
-
-(define (conscount c)
- (if (pair? c) (+ 1
- (conscount (car c))
- (conscount (cdr c)))
- 0))
-
-; _ Welcome to
-; (_ _ _ |_ _ | . _ _ 2
-; | (-||||_(_)|__|_)|_)
-; ==================|==
-
-;[` _ ,_ |- | . _ 2
-;| (/_||||_()|_|_\|)
-; |
-
-(define-macro (while- test . forms)
- `((label -loop- (lambda ()
- (if ,test
- (begin ,@forms
- (-loop-))
- ())))))
-
-; this would be a cool use of thunking to handle 'finally' clauses, but
-; this code doesn't work in the case where the user manually re-raises
-; inside a catch block. one way to handle it would be to replace all
-; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
-; (try expr
-; (catch (TypeError e) . exprs)
-; (catch (IOError e) . exprs)
-; (finally . exprs))
-(define-macro (try expr . forms)
- (let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
- (body (foldr
- ; create a function to check for and handle one exception
- ; type, and pass off control to the next when no match
- (lambda (catc next)
- (let ((var (cadr (cadr catc)))
- (extype (caadr catc))
- (todo (f-body (cddr catc))))
- `(lambda (,var)
- (if (or (eq ,var ',extype)
- (and (pair? ,var)
- (eq (car ,var) ',extype)))
- ,todo
- (,next ,var)))))
-
- ; default function; no matches so re-raise
- '(lambda (e) (begin (*_try_finally_thunk_*) (raise e)))
-
- ; make list of catch forms
- (filter (lambda (f) (eq (car f) 'catch)) forms))))
- `(let ((*_try_finally_thunk_* (lambda () ,final)))
- (prog1 (attempt ,expr ,body)
- (*_try_finally_thunk_*)))))
-
-(define Y
- (lambda (f)
- ((lambda (h)
- (f (lambda (x) ((h h) x))))
- (lambda (h)
- (f (lambda (x) ((h h) x)))))))
-
-(define yfib
- (Y (lambda (fib)
- (lambda (n)
- (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
-
-;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
-;(tt)
-;(tt)
-;(tt)
-
-(define-macro (accumulate-while cnd what . body)
- (let ((acc (gensym)))
- `(let ((,acc (list ())))
- (cdr
- (prog1 ,acc
- (while ,cnd
- (begin (set! ,acc
- (cdr (set-cdr! ,acc (cons ,what ()))))
- ,@body)))))))
-
-(define-macro (accumulate-for var lo hi what . body)
- (let ((acc (gensym)))
- `(let ((,acc (list ())))
- (cdr
- (prog1 ,acc
- (for ,lo ,hi
- (lambda (,var)
- (begin (set! ,acc
- (cdr (set-cdr! ,acc (cons ,what ()))))
- ,@body))))))))
-
-(define (map-indexed f lst)
- (if (atom? lst) lst
- (let ((i 0))
- (accumulate-while (pair? lst) (f (car lst) i)
- (begin (set! lst (cdr lst))
- (set! i (1+ i)))))))
-
-(define (string.findall haystack needle . offs)
- (define (sub h n offs lst)
- (let ((i (string.find h n offs)))
- (if i
- (sub h n (string.inc h i) (cons i lst))
- (reverse! lst))))
- (sub haystack needle (if (null? offs) 0 (car offs)) ()))
-
-(let ((*profiles* (table)))
- (set! profile
- (lambda (s)
- (let ((f (top-level-value s)))
- (put! *profiles* s (cons 0 0))
- (set-top-level-value! s
- (lambda args
- (define tt (get *profiles* s))
- (define count (car tt))
- (define time (cdr tt))
- (define t0 (time.now))
- (define v (apply f args))
- (set-cdr! tt (+ time (- (time.now) t0)))
- (set-car! tt (+ count 1))
- v)))))
- (set! show-profiles
- (lambda ()
- (define pr (filter (lambda (x) (> (cadr x) 0))
- (table.pairs *profiles*)))
- (define width (+ 4
- (apply max
- (map (lambda (x)
- (length (string x)))
- (cons 'Function
- (map car pr))))))
- (princ (string.rpad "Function" width #\ )
- "#Calls Time (seconds)")
- (newline)
- (princ (string.rpad "--------" width #\ )
- "------ --------------")
- (newline)
- (for-each
- (lambda (p)
- (princ (string.rpad (string (caddr p)) width #\ )
- (string.rpad (string (cadr p)) 11 #\ )
- (car p))
- (newline))
- (simple-sort (map (lambda (l) (reverse (to-proper l)))
- pr)))))
- (set! clear-profiles
- (lambda ()
- (for-each (lambda (k)
- (put! *profiles* k (cons 0 0)))
- (table.keys *profiles*)))))
-
-#;(for-each profile
- '(emit encode-byte-code const-to-idx-vec
- index-of lookup-sym in-env? any every
- compile-sym compile-if compile-begin
- compile-arglist expand builtin->instruction
- compile-app separate nconc get-defined-vars
- compile-in compile compile-f delete-duplicates
- map length> length= count filter append
- lastcdr to-proper reverse reverse! list->vector
- table.foreach list-head list-tail assq memq assoc member
- assv memv nreconc bq-process))
-
-(define (filt1 pred lst)
- (define (filt1- pred lst accum)
- (if (null? lst) accum
- (if (pred (car lst))
- (filt1- pred (cdr lst) (cons (car lst) accum))
- (filt1- pred (cdr lst) accum))))
- (filt1- pred lst ()))
-
-(define (filto pred lst (accum ()))
- (if (atom? lst) accum
- (if (pred (car lst))
- (filto pred (cdr lst) (cons (car lst) accum))
- (filto pred (cdr lst) accum))))
-
-; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
-(define (pairwise? pred . args)
- (or (null? args)
- (let f ((a (car args)) (d (cdr args)))
- (or (null? d)
- (and (pred a (car d)) (f (car d) (cdr d)))))))
--- /dev/null
+++ b/femtolisp/tests/100x100.lsp
@@ -1,0 +1,1 @@
+'#0=(#198=(#197=(#196=(#195=(#194=(#193=(#192=(#191=(#190=(#189=(#188=(#187=(#186=(#185=(#184=(#183=(#182=(#181=(#180=(#179=(#178=(#177=(#176=(#175=(#174=(#173=(#172=(#171=(#170=(#169=(#168=(#167=(#166=(#165=(#164=(#163=(#162=(#161=(#160=(#159=(#158=(#157=(#156=(#155=(#154=(#153=(#152=(#151=(#150=(#149=(#148=(#147=(#146=(#145=(#144=(#143=(#142=(#141=(#140=(#139=(#138=(#137=(#136=(#135=(#134=(#133=(#132=(#131=(#130=(#129=(#128=(#127=(#126=(#125=(#124=(#123=(#122=(#121=(#120=(#119=(#118=(#117=(#116=(#115=(#114=(#113=(#112=(#111=(#110=(#109=(#108=(#107=(#106=(#105=(#104=(#103=(#102=(#101=(#100=(#0# . #1=(#9999=(#9998=(#9997=(#9996=(#9995=(#9994=(#9993=(#9992=(#9991=(#9990=(#9989=(#9988=(#9987=(#9986=(#9985=(#9984=(#9983=(#9982=(#9981=(#9980=(#9979=(#9978=(#9977=(#9976=(#9975=(#9974=(#9973=(#9972=(#9971=(#9970=(#9969=(#9968=(#9967=(#9966=(#9965=(#9964=(#9963=(#9962=(#9961=(#9960=(#9959=(#9958=(#9957=(#9956=(#9955=(#9954=(#9953=(#9952=(#9951=(#9950=(#9949=(#9948=(#9947=(#9946=(#9945=(#9944=(#9943=(#9942=(#9941=(#9940=(#9939=(#9938=(#9937=(#9936=(#9935=(#9934=(#9933=(#9932=(#9931=(#9930=(#9929=(#9928=(#9927=(#9926=(#9925=(#9924=(#9923=(#9922=(#9921=(#9920=(#9919=(#9918=(#9917=(#9916=(#9915=(#9914=(#9913=(#9912=(#9911=(#9910=(#9909=(#9908=(#9907=(#9906=(#9905=(#9904=(#9903=(#9902=(#9901=(#1# . #2=(#9900=(#9899=(#9898=(#9897=(#9896=(#9895=(#9894=(#9893=(#9892=(#9891=(#9890=(#9889=(#9888=(#9887=(#9886=(#9885=(#9884=(#9883=(#9882=(#9881=(#9880=(#9879=(#9878=(#9877=(#9876=(#9875=(#9874=(#9873=(#9872=(#9871=(#9870=(#9869=(#9868=(#9867=(#9866=(#9865=(#9864=(#9863=(#9862=(#9861=(#9860=(#9859=(#9858=(#9857=(#9856=(#9855=(#9854=(#9853=(#9852=(#9851=(#9850=(#9849=(#9848=(#9847=(#9846=(#9845=(#9844=(#9843=(#9842=(#9841=(#9840=(#9839=(#9838=(#9837=(#9836=(#9835=(#9834=(#9833=(#9832=(#9831=(#9830=(#9829=(#9828=(#9827=(#9826=(#9825=(#9824=(#9823=(#9822=(#9821=(#9820=(#9819=(#9818=(#9817=(#9816=(#9815=(#9814=(#9813=(#9812=(#9811=(#9810=(#9809=(#9808=(#9807=(#9806=(#9805=(#9804=(#9803=(#9802=(#2# . #3=(#9801=(#9800=(#9799=(#9798=(#9797=(#9796=(#9795=(#9794=(#9793=(#9792=(#9791=(#9790=(#9789=(#9788=(#9787=(#9786=(#9785=(#9784=(#9783=(#9782=(#9781=(#9780=(#9779=(#9778=(#9777=(#9776=(#9775=(#9774=(#9773=(#9772=(#9771=(#9770=(#9769=(#9768=(#9767=(#9766=(#9765=(#9764=(#9763=(#9762=(#9761=(#9760=(#9759=(#9758=(#9757=(#9756=(#9755=(#9754=(#9753=(#9752=(#9751=(#9750=(#9749=(#9748=(#9747=(#9746=(#9745=(#9744=(#9743=(#9742=(#9741=(#9740=(#9739=(#9738=(#9737=(#9736=(#9735=(#9734=(#9733=(#9732=(#9731=(#9730=(#9729=(#9728=(#9727=(#9726=(#9725=(#9724=(#9723=(#9722=(#9721=(#9720=(#9719=(#9718=(#9717=(#9716=(#9715=(#9714=(#9713=(#9712=(#9711=(#9710=(#9709=(#9708=(#9707=(#9706=(#9705=(#9704=(#9703=(#3# . #4=(#9702=(#9701=(#9700=(#9699=(#9698=(#9697=(#9696=(#9695=(#9694=(#9693=(#9692=(#9691=(#9690=(#9689=(#9688=(#9687=(#9686=(#9685=(#9684=(#9683=(#9682=(#9681=(#9680=(#9679=(#9678=(#9677=(#9676=(#9675=(#9674=(#9673=(#9672=(#9671=(#9670=(#9669=(#9668=(#9667=(#9666=(#9665=(#9664=(#9663=(#9662=(#9661=(#9660=(#9659=(#9658=(#9657=(#9656=(#9655=(#9654=(#9653=(#9652=(#9651=(#9650=(#9649=(#9648=(#9647=(#9646=(#9645=(#9644=(#9643=(#9642=(#9641=(#9640=(#9639=(#9638=(#9637=(#9636=(#9635=(#9634=(#9633=(#9632=(#9631=(#9630=(#9629=(#9628=(#9627=(#9626=(#9625=(#9624=(#9623=(#9622=(#9621=(#9620=(#9619=(#9618=(#9617=(#9616=(#9615=(#9614=(#9613=(#9612=(#9611=(#9610=(#9609=(#9608=(#9607=(#9606=(#9605=(#9604=(#4# . #5=(#9603=(#9602=(#9601=(#9600=(#9599=(#9598=(#9597=(#9596=(#9595=(#9594=(#9593=(#9592=(#9591=(#9590=(#9589=(#9588=(#9587=(#9586=(#9585=(#9584=(#9583=(#9582=(#9581=(#9580=(#9579=(#9578=(#9577=(#9576=(#9575=(#9574=(#9573=(#9572=(#9571=(#9570=(#9569=(#9568=(#9567=(#9566=(#9565=(#9564=(#9563=(#9562=(#9561=(#9560=(#9559=(#9558=(#9557=(#9556=(#9555=(#9554=(#9553=(#9552=(#9551=(#9550=(#9549=(#9548=(#9547=(#9546=(#9545=(#9544=(#9543=(#9542=(#9541=(#9540=(#9539=(#9538=(#9537=(#9536=(#9535=(#9534=(#9533=(#9532=(#9531=(#9530=(#9529=(#9528=(#9527=(#9526=(#9525=(#9524=(#9523=(#9522=(#9521=(#9520=(#9519=(#9518=(#9517=(#9516=(#9515=(#9514=(#9513=(#9512=(#9511=(#9510=(#9509=(#9508=(#9
\ No newline at end of file
--- /dev/null
+++ b/femtolisp/tests/color.lsp
@@ -1,0 +1,89 @@
+; -*- scheme -*-
+
+; dictionaries ----------------------------------------------------------------
+(define (dict-new) ())
+
+(define (dict-extend dl key value)
+ (cond ((null? dl) (list (cons key value)))
+ ((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
+ (else (cons (car dl) (dict-extend (cdr dl) key value)))))
+
+(define (dict-lookup dl key)
+ (cond ((null? dl) ())
+ ((equal? key (caar dl)) (cdar dl))
+ (else (dict-lookup (cdr dl) key))))
+
+(define (dict-keys dl) (map car dl))
+
+; graphs ----------------------------------------------------------------------
+(define (graph-empty) (dict-new))
+
+(define (graph-connect g n1 n2)
+ (dict-extend
+ (dict-extend g n2 (cons n1 (dict-lookup g n2)))
+ n1
+ (cons n2 (dict-lookup g n1))))
+
+(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
+
+(define (graph-neighbors g n) (dict-lookup g n))
+
+(define (graph-nodes g) (dict-keys g))
+
+(define (graph-add-node g n1) (dict-extend g n1 ()))
+
+(define (graph-from-edges edge-list)
+ (if (null? edge-list)
+ (graph-empty)
+ (graph-connect (graph-from-edges (cdr edge-list))
+ (caar edge-list)
+ (cdar edge-list))))
+
+; graph coloring --------------------------------------------------------------
+(define (node-colorable? g coloring node-to-color color-of-node)
+ (not (member
+ color-of-node
+ (map
+ (lambda (n)
+ (let ((color-pair (assq n coloring)))
+ (if (pair? color-pair) (cdr color-pair) ())))
+ (graph-neighbors g node-to-color)))))
+
+(define (try-each f lst)
+ (if (null? lst) #f
+ (let ((ret (f (car lst))))
+ (if ret ret (try-each f (cdr lst))))))
+
+(define (color-node g coloring colors uncolored-nodes color)
+ (cond
+ ((null? uncolored-nodes) coloring)
+ ((node-colorable? g coloring (car uncolored-nodes) color)
+ (let ((new-coloring
+ (cons (cons (car uncolored-nodes) color) coloring)))
+ (try-each (lambda (c)
+ (color-node g new-coloring colors (cdr uncolored-nodes) c))
+ colors)))))
+
+(define (color-graph g colors)
+ (if (null? colors)
+ (and (null? (graph-nodes g)) ())
+ (color-node g () colors (graph-nodes g) (car colors))))
+
+(define (color-pairs pairs colors)
+ (color-graph (graph-from-edges pairs) colors))
+
+; queens ----------------------------------------------------------------------
+(define (can-attack x y)
+ (let ((x1 (mod x 5))
+ (y1 (truncate (/ x 5)))
+ (x2 (mod y 5))
+ (y2 (truncate (/ y 5))))
+ (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
+
+(define (generate-5x5-pairs)
+ (let ((result ()))
+ (dotimes (x 25)
+ (dotimes (y 25)
+ (if (and (not (= x y)) (can-attack x y))
+ (set! result (cons (cons x y) result)) ())))
+ result))
--- /dev/null
+++ b/femtolisp/tests/perf.lsp
@@ -1,0 +1,37 @@
+(load "test.lsp")
+
+(princ "colorgraph: ")
+(load "tcolor.lsp")
+
+(princ "fib(34): ")
+(assert (equal? (time (fib 34)) 5702887))
+(princ "yfib(32): ")
+(assert (equal? (time (yfib 32)) 2178309))
+
+(princ "sort: ")
+(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
+(time (simple-sort r))
+
+(princ "expand: ")
+(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
+
+(define (my-append . lsts)
+ (cond ((null? lsts) ())
+ ((null? (cdr lsts)) (car lsts))
+ (else (letrec ((append2 (lambda (l d)
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d))))))
+ (append2 (car lsts) (apply my-append (cdr lsts)))))))
+
+(princ "append: ")
+(set! L (map-int (lambda (x) (map-int identity 20)) 20))
+(time (dotimes (n 1000) (apply my-append L)))
+
+(path.cwd "ast")
+(princ "p-lambda: ")
+(load "rpasses.lsp")
+(define *input* (load "datetimeR.lsp"))
+(time (set! *output* (compile-ish *input*)))
+(assert (equal? *output* (load "rpasses-out.lsp")))
+(path.cwd "..")
--- /dev/null
+++ b/femtolisp/tests/tcolor.lsp
@@ -1,0 +1,16 @@
+; -*- scheme -*-
+; color for performance
+
+(load "color.lsp")
+
+; 100x color 5 queens
+(define Q (generate-5x5-pairs))
+(define (ct)
+ (set! C (color-pairs Q '(a b c d e)))
+ (dotimes (n 99) (color-pairs Q '(a b c d e))))
+(time (ct))
+(assert (equal? C
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
--- /dev/null
+++ b/femtolisp/tests/test.lsp
@@ -1,0 +1,294 @@
+; -*- scheme -*-
+
+; make label self-evaluating, but evaluating the lambda in the process
+;(defmacro labl (name f)
+; (list list ''labl (list 'quote name) f))
+
+(define-macro (labl name f)
+ `(let (,name) (set! ,name ,f)))
+
+;(define (reverse lst)
+; ((label rev-help (lambda (lst result)
+; (if (null? lst) result
+; (rev-help (cdr lst) (cons (car lst) result)))))
+; lst ()))
+
+(define (append- . lsts)
+ ((label append-h
+ (lambda (lsts)
+ (cond ((null? lsts) ())
+ ((null? (cdr lsts)) (car lsts))
+ (#t ((label append2 (lambda (l d)
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (append-h (cdr lsts)))))))
+ lsts))
+
+;(princ 'Hello '| | 'world! "\n")
+;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
+(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+;(princ (time (fib 34)) "\n")
+;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
+;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
+;(dotimes (i 80000) (list 1 2 3 4 5))
+;(set! a (map-int identity 10000))
+;(dotimes (i 200) (rfoldl cons () a))
+
+#|
+(define-macro (dotimes var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ `(let ((,v 0))
+ (while (< ,v ,cnt)
+ (prog1
+ ,(cons 'begin body)
+ (set! ,v (+ ,v 1)))))))
+
+(define (map-int f n)
+ (if (<= n 0)
+ ()
+ (let ((first (cons (f 0) ())))
+ ((label map-int-
+ (lambda (acc i n)
+ (if (= i n)
+ first
+ (begin (set-cdr! acc (cons (f i) ()))
+ (map-int- (cdr acc) (+ i 1) n)))))
+ first 1 n))))
+|#
+
+(define-macro (labl name fn)
+ `((lambda (,name) (set! ,name ,fn)) ()))
+
+(define (square x) (* x x))
+(define (expt b p)
+ (cond ((= p 0) 1)
+ ((= b 0) 0)
+ ((even? p) (square (expt b (div0 p 2))))
+ (#t (* b (expt b (- p 1))))))
+
+(define (gcd a b)
+ (cond ((= a 0) b)
+ ((= b 0) a)
+ ((< a b) (gcd a (- b a)))
+ (#t (gcd b (- a b)))))
+
+; like eval-when-compile
+(define-macro (literal expr)
+ (let ((v (eval expr)))
+ (if (self-evaluating? v) v (list quote v))))
+
+(define (cardepth l)
+ (if (atom? l) 0
+ (+ 1 (cardepth (car l)))))
+
+(define (nestlist f zero n)
+ (if (<= n 0) ()
+ (cons zero (nestlist f (f zero) (- n 1)))))
+
+(define (mapl f . lsts)
+ ((label mapl-
+ (lambda (lsts)
+ (if (null? (car lsts)) ()
+ (begin (apply f lsts) (mapl- (map cdr lsts))))))
+ lsts))
+
+; test to see if a symbol begins with :
+(define (keywordp s)
+ (and (>= s '|:|) (<= s '|:~|)))
+
+; swap the cars and cdrs of every cons in a structure
+(define (swapad c)
+ (if (atom? c) c
+ (set-cdr! c (K (swapad (car c))
+ (set-car! c (swapad (cdr c)))))))
+
+(define (without x l)
+ (filter (lambda (e) (not (eq e x))) l))
+
+(define (conscount c)
+ (if (pair? c) (+ 1
+ (conscount (car c))
+ (conscount (cdr c)))
+ 0))
+
+; _ Welcome to
+; (_ _ _ |_ _ | . _ _ 2
+; | (-||||_(_)|__|_)|_)
+; ==================|==
+
+;[` _ ,_ |- | . _ 2
+;| (/_||||_()|_|_\|)
+; |
+
+(define-macro (while- test . forms)
+ `((label -loop- (lambda ()
+ (if ,test
+ (begin ,@forms
+ (-loop-))
+ ())))))
+
+; this would be a cool use of thunking to handle 'finally' clauses, but
+; this code doesn't work in the case where the user manually re-raises
+; inside a catch block. one way to handle it would be to replace all
+; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
+; (try expr
+; (catch (TypeError e) . exprs)
+; (catch (IOError e) . exprs)
+; (finally . exprs))
+(define-macro (try expr . forms)
+ (let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
+ (body (foldr
+ ; create a function to check for and handle one exception
+ ; type, and pass off control to the next when no match
+ (lambda (catc next)
+ (let ((var (cadr (cadr catc)))
+ (extype (caadr catc))
+ (todo (f-body (cddr catc))))
+ `(lambda (,var)
+ (if (or (eq ,var ',extype)
+ (and (pair? ,var)
+ (eq (car ,var) ',extype)))
+ ,todo
+ (,next ,var)))))
+
+ ; default function; no matches so re-raise
+ '(lambda (e) (begin (*_try_finally_thunk_*) (raise e)))
+
+ ; make list of catch forms
+ (filter (lambda (f) (eq (car f) 'catch)) forms))))
+ `(let ((*_try_finally_thunk_* (lambda () ,final)))
+ (prog1 (attempt ,expr ,body)
+ (*_try_finally_thunk_*)))))
+
+(define Y
+ (lambda (f)
+ ((lambda (h)
+ (f (lambda (x) ((h h) x))))
+ (lambda (h)
+ (f (lambda (x) ((h h) x)))))))
+
+(define yfib
+ (Y (lambda (fib)
+ (lambda (n)
+ (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
+
+;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
+;(tt)
+;(tt)
+;(tt)
+
+(define-macro (accumulate-while cnd what . body)
+ (let ((acc (gensym)))
+ `(let ((,acc (list ())))
+ (cdr
+ (prog1 ,acc
+ (while ,cnd
+ (begin (set! ,acc
+ (cdr (set-cdr! ,acc (cons ,what ()))))
+ ,@body)))))))
+
+(define-macro (accumulate-for var lo hi what . body)
+ (let ((acc (gensym)))
+ `(let ((,acc (list ())))
+ (cdr
+ (prog1 ,acc
+ (for ,lo ,hi
+ (lambda (,var)
+ (begin (set! ,acc
+ (cdr (set-cdr! ,acc (cons ,what ()))))
+ ,@body))))))))
+
+(define (map-indexed f lst)
+ (if (atom? lst) lst
+ (let ((i 0))
+ (accumulate-while (pair? lst) (f (car lst) i)
+ (begin (set! lst (cdr lst))
+ (set! i (1+ i)))))))
+
+(define (string.findall haystack needle . offs)
+ (define (sub h n offs lst)
+ (let ((i (string.find h n offs)))
+ (if i
+ (sub h n (string.inc h i) (cons i lst))
+ (reverse! lst))))
+ (sub haystack needle (if (null? offs) 0 (car offs)) ()))
+
+(let ((*profiles* (table)))
+ (set! profile
+ (lambda (s)
+ (let ((f (top-level-value s)))
+ (put! *profiles* s (cons 0 0))
+ (set-top-level-value! s
+ (lambda args
+ (define tt (get *profiles* s))
+ (define count (car tt))
+ (define time (cdr tt))
+ (define t0 (time.now))
+ (define v (apply f args))
+ (set-cdr! tt (+ time (- (time.now) t0)))
+ (set-car! tt (+ count 1))
+ v)))))
+ (set! show-profiles
+ (lambda ()
+ (define pr (filter (lambda (x) (> (cadr x) 0))
+ (table.pairs *profiles*)))
+ (define width (+ 4
+ (apply max
+ (map (lambda (x)
+ (length (string x)))
+ (cons 'Function
+ (map car pr))))))
+ (princ (string.rpad "Function" width #\ )
+ "#Calls Time (seconds)")
+ (newline)
+ (princ (string.rpad "--------" width #\ )
+ "------ --------------")
+ (newline)
+ (for-each
+ (lambda (p)
+ (princ (string.rpad (string (caddr p)) width #\ )
+ (string.rpad (string (cadr p)) 11 #\ )
+ (car p))
+ (newline))
+ (simple-sort (map (lambda (l) (reverse (to-proper l)))
+ pr)))))
+ (set! clear-profiles
+ (lambda ()
+ (for-each (lambda (k)
+ (put! *profiles* k (cons 0 0)))
+ (table.keys *profiles*)))))
+
+#;(for-each profile
+ '(emit encode-byte-code const-to-idx-vec
+ index-of lookup-sym in-env? any every
+ compile-sym compile-if compile-begin
+ compile-arglist expand builtin->instruction
+ compile-app separate nconc get-defined-vars
+ compile-in compile compile-f delete-duplicates
+ map length> length= count filter append
+ lastcdr to-proper reverse reverse! list->vector
+ table.foreach list-head list-tail assq memq assoc member
+ assv memv nreconc bq-process))
+
+(define (filt1 pred lst)
+ (define (filt1- pred lst accum)
+ (if (null? lst) accum
+ (if (pred (car lst))
+ (filt1- pred (cdr lst) (cons (car lst) accum))
+ (filt1- pred (cdr lst) accum))))
+ (filt1- pred lst ()))
+
+(define (filto pred lst (accum ()))
+ (if (atom? lst) accum
+ (if (pred (car lst))
+ (filto pred (cdr lst) (cons (car lst) accum))
+ (filto pred (cdr lst) accum))))
+
+; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
+(define (pairwise? pred . args)
+ (or (null? args)
+ (let f ((a (car args)) (d (cdr args)))
+ (or (null? d)
+ (and (pred a (car d)) (f (car d) (cdr d)))))))
--- /dev/null
+++ b/femtolisp/tests/torture.scm
@@ -1,0 +1,24 @@
+(define ones (map (lambda (x) 1) (iota 1000000)))
+
+(write (apply + ones))
+(newline)
+
+(define (big n)
+ (if (<= n 0)
+ 0
+ `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
+
+(define nst (big 100000))
+
+(write (eval nst))
+(newline)
+
+(define longg (cons '+ ones))
+(write (eval longg))
+(newline)
+
+(define (f x)
+ (begin (write x)
+ (newline)
+ (f (+ x 1))
+ 0))
--- /dev/null
+++ b/femtolisp/tests/torus.lsp
@@ -1,0 +1,48 @@
+; -*- scheme -*-
+(define (maplist f l)
+ (if (null? l) ()
+ (cons (f l) (maplist f (cdr l)))))
+
+; produce a beautiful, toroidal cons structure
+; make m copies of a CDR-circular list of length n, and connect corresponding
+; conses in CAR-circular loops
+; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use
+(define (torus m n)
+ (let* ((l (map-int identity n))
+ (g l)
+ (prev g))
+ (dotimes (i (- m 1))
+ (set! prev g)
+ (set! g (maplist identity g))
+ (set-cdr! (last-pair prev) prev))
+ (set-cdr! (last-pair g) g)
+ (let ((a l)
+ (b g))
+ (dotimes (i n)
+ (set-car! a b)
+ (set! a (cdr a))
+ (set! b (cdr b))))
+ l))
+
+(define (cyl m n)
+ (let* ((l (map-int identity n))
+ (g l))
+ (dotimes (i (- m 1))
+ (set! g (maplist identity g)))
+ (let ((a l)
+ (b g))
+ (dotimes (i n)
+ (set-car! a b)
+ (set! a (cdr a))
+ (set! b (cdr b))))
+ l))
+
+(time (begin (print (torus 100 100)) ()))
+;(time (dotimes (i 1) (load "100x100.lsp")))
+; with ltable
+; printing time: 0.415sec
+; reading time: 0.165sec
+
+; with ptrhash
+; printing time: 0.081sec
+; reading time: 0.0264sec
--- /dev/null
+++ b/femtolisp/tests/unittest.lsp
@@ -1,0 +1,274 @@
+; -*- scheme -*-
+(define-macro (assert-fail expr . what)
+ `(assert (trycatch (begin ,expr #f)
+ (lambda (e) ,(if (null? what) #t
+ `(eq? (car e) ',(car what)))))))
+
+(define (every-int n)
+ (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
+ (int64 n) (uint64 n)))
+
+(define (every-sint n)
+ (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
+
+(define (each f l)
+ (if (atom? l) ()
+ (begin (f (car l))
+ (each f (cdr l)))))
+
+(define (each^2 f l m)
+ (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
+
+(define (test-lt a b)
+ (each^2 (lambda (neg pos)
+ (begin
+ (eval `(assert (= -1 (compare ,neg ,pos))))
+ (eval `(assert (= 1 (compare ,pos ,neg))))))
+ a
+ b))
+
+(define (test-eq a b)
+ (each^2 (lambda (a b)
+ (begin
+ (eval `(assert (= 0 (compare ,a ,b))))))
+ a
+ b))
+
+(test-lt (every-sint -1) (every-int 1))
+(test-lt (every-int 0) (every-int 1))
+(test-eq (every-int 88) (every-int 88))
+(test-eq (every-sint -88) (every-sint -88))
+
+(define (test-square a)
+ (each (lambda (i) (eval `(assert (>= (* ,i ,i) 0))))
+ a))
+
+(test-square (every-sint -67))
+(test-square (every-int 3))
+(test-square (every-int 0x80000000))
+(test-square (every-sint 0x80000000))
+(test-square (every-sint -0x80000000))
+
+(assert (= (* 128 0x02000001) 0x100000080))
+
+(assert (= (/ 1) 1))
+(assert (= (/ -1) -1))
+(assert (= (/ 2.0) 0.5))
+
+(assert (= (- 4999950000 4999941999) 8001))
+
+(assert (not (eqv? 10 #\newline)))
+(assert (not (eqv? #\newline 10)))
+
+; tricky cases involving INT_MIN
+(assert (< (- #uint32(0x80000000)) 0))
+(assert (> (- #int32(0x80000000)) 0))
+(assert (< (- #uint64(0x8000000000000000)) 0))
+(assert (> (- #int64(0x8000000000000000)) 0))
+
+(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
+(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+(assert (equal? (* 2 #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+
+(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
+
+(assert (equal? (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
+
+; NaNs
+(assert (equal? +nan.0 +nan.0))
+(assert (not (= +nan.0 +nan.0)))
+(assert (not (= +nan.0 -nan.0)))
+(assert (equal? (< +nan.0 3) (> 3 +nan.0)))
+(assert (equal? (< +nan.0 (double 3)) (> (double 3) +nan.0)))
+(assert (equal? (< +nan.0 3) (> (double 3) +nan.0)))
+(assert (equal? (< +nan.0 (double 3)) (> 3 +nan.0)))
+(assert (equal? (< +nan.0 3) (< +nan.0 (double 3))))
+(assert (equal? (> +nan.0 3) (> +nan.0 (double 3))))
+(assert (equal? (< 3 +nan.0) (> +nan.0 (double 3))))
+(assert (equal? (> 3 +nan.0) (> (double 3) +nan.0)))
+(assert (not (>= +nan.0 +nan.0)))
+
+; -0.0 etc.
+(assert (not (equal? 0.0 0)))
+(assert (equal? 0.0 0.0))
+(assert (not (equal? -0.0 0.0)))
+(assert (not (equal? -0.0 0)))
+(assert (not (eqv? 0.0 0)))
+(assert (not (eqv? -0.0 0)))
+(assert (not (eqv? -0.0 0.0)))
+(assert (= 0.0 -0.0))
+
+; this crashed once
+(for 1 10 (lambda (i) 0))
+
+; failing applications
+(assert-fail ((lambda (x) x) 1 2))
+(assert-fail ((lambda (x) x)))
+(assert-fail ((lambda (x y . z) z) 1))
+(assert-fail (car 'x) type-error)
+(assert-fail gjegherqpfdf___trejif unbound-error)
+
+; long argument lists
+(assert (= (apply + (iota 100000)) 4999950000))
+(define ones (map (lambda (x) 1) (iota 80000)))
+(assert (= (eval `(if (< 2 1)
+ (+ ,@ones)
+ (+ ,@(cdr ones))))
+ 79999))
+
+(define MAX_ARGS 255)
+
+(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1))))
+(define f (compile `(lambda ,as ,(lastcdr as))))
+(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))
+(assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
+(assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
+
+(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
+(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
+ ,(car (last-pair as)))))
+(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
+(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
+ (lambda () ,(car (last-pair as))))))
+(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
+
+(define as (map-int (lambda (x) (gensym)) 1000))
+(define f (compile `(lambda ,as ,(car (last-pair as)))))
+(assert (equal? (apply f (iota 1000)) 999))
+
+(define as (apply list* (map-int (lambda (x) (gensym)) 995)))
+(define f (compile `(lambda ,as ,(lastcdr as))))
+(assert (equal? (apply f (iota 994)) '()))
+(assert (equal? (apply f (iota 995)) '(994)))
+(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
+
+; optional arguments
+(assert (equal? ((lambda ((b 0)) b)) 0))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
+(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ())))
+(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
+
+; keyword arguments
+(assert (keyword? kw:))
+(assert (not (keyword? 'kw)))
+(assert (not (keyword? ':)))
+(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
+ '(1 0 0 (8 4 5))))
+(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
+ '(0 2 3 (1))))
+(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
+(assert (equal? (keys4 a: 10) '(10 3 7 6)))
+(assert (equal? (keys4 b: 10) '(8 10 7 6)))
+(assert (equal? (keys4 c: 10) '(8 3 10 6)))
+(assert (equal? (keys4 d: 10) '(8 3 7 10)))
+(assert-fail (keys4 e: 10)) ; unsupported keyword
+(assert-fail (keys4 a: 1 b:)) ; keyword with no argument
+
+; cvalues and arrays
+(assert (equal? (typeof "") '(array byte)))
+(assert-fail (aref #(1) 3) bounds-error)
+(define iarr (array 'int64 32 16 8 7 1))
+(assert (equal? (aref iarr 0) 32))
+(assert (equal? (aref iarr #int8(3)) 7))
+
+; gensyms
+(assert (gensym? (gensym)))
+(assert (not (gensym? 'a)))
+(assert (not (eq? (gensym) (gensym))))
+(assert (not (equal? (string (gensym)) (string (gensym)))))
+(let ((gs (gensym))) (assert (eq? gs gs)))
+
+; eof object
+(assert (eof-object? (eof-object)))
+(assert (not (eof-object? 1)))
+(assert (not (eof-object? 'a)))
+(assert (not (eof-object? '())))
+(assert (not (eof-object? #f)))
+(assert (not (null? (eof-object))))
+(assert (not (builtin? (eof-object))))
+(assert (not (function? (eof-object))))
+
+; ok, a couple end-to-end tests as well
+(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+(assert (equal? (fib 20) 6765))
+
+(load "color.lsp")
+(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
+
+; hashing strange things
+(assert (equal?
+ (hash '#0=(1 1 #0# . #0#))
+ (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
+
+(assert (not (equal?
+ (hash '#0=(1 1 #0# . #0#))
+ (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
+
+(assert (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
+
+(assert (not (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
+
+(assert (not (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
+
+(assert (equal?
+ (hash '(#0=(#0#) 0))
+ (hash '(#1=(((((#1#))))) 0))))
+
+(assert (not (equal?
+ (hash '(#0=(#0#) 0))
+ (hash '(#1=(((((#1#))))) 1)))))
+
+(assert (equal?
+ (hash #0=[1 [2 [#0#]] 3])
+ (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash #0=[1 [2 [#0#]] 3])
+ (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3]))))
+
+(assert (equal?
+ (hash #0=[1 #0# [2 [#0#]] 3])
+ (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash #0=[1 #0# [2 [#0#]] 3])
+ (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))))
+
+(assert (equal?
+ (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])
+ (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3])
+ (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3]))))
+
+(assert (equal? (hash '#0=(1 . #0#))
+ (hash '#1=(1 1 . #1#))))
+
+(assert (not (equal? (hash '#0=(1 1 . #0#))
+ (hash '#1=(1 #0# . #1#)))))
+
+(assert (not (equal? (hash (iota 10))
+ (hash (iota 20)))))
+
+(assert (not (equal? (hash (iota 41))
+ (hash (iota 42)))))
+
+(princ "all tests pass\n")
+#t
binary files a/femtolisp/tiny/lisp /dev/null differ
binary files a/femtolisp/tiny/lisp2 /dev/null differ
binary files a/femtolisp/tiny/lispf /dev/null differ
--- a/femtolisp/torture.scm
+++ /dev/null
@@ -1,24 +1,0 @@
-(define ones (map (lambda (x) 1) (iota 1000000)))
-
-(write (apply + ones))
-(newline)
-
-(define (big n)
- (if (<= n 0)
- 0
- `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
-
-(define nst (big 100000))
-
-(write (eval nst))
-(newline)
-
-(define longg (cons '+ ones))
-(write (eval longg))
-(newline)
-
-(define (f x)
- (begin (write x)
- (newline)
- (f (+ x 1))
- 0))
--- a/femtolisp/torus.lsp
+++ /dev/null
@@ -1,48 +1,0 @@
-; -*- scheme -*-
-(define (maplist f l)
- (if (null? l) ()
- (cons (f l) (maplist f (cdr l)))))
-
-; produce a beautiful, toroidal cons structure
-; make m copies of a CDR-circular list of length n, and connect corresponding
-; conses in CAR-circular loops
-; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use
-(define (torus m n)
- (let* ((l (map-int identity n))
- (g l)
- (prev g))
- (dotimes (i (- m 1))
- (set! prev g)
- (set! g (maplist identity g))
- (set-cdr! (last-pair prev) prev))
- (set-cdr! (last-pair g) g)
- (let ((a l)
- (b g))
- (dotimes (i n)
- (set-car! a b)
- (set! a (cdr a))
- (set! b (cdr b))))
- l))
-
-(define (cyl m n)
- (let* ((l (map-int identity n))
- (g l))
- (dotimes (i (- m 1))
- (set! g (maplist identity g)))
- (let ((a l)
- (b g))
- (dotimes (i n)
- (set-car! a b)
- (set! a (cdr a))
- (set! b (cdr b))))
- l))
-
-(time (begin (print (torus 100 100)) ()))
-;(time (dotimes (i 1) (load "100x100.lsp")))
-; with ltable
-; printing time: 0.415sec
-; reading time: 0.165sec
-
-; with ptrhash
-; printing time: 0.081sec
-; reading time: 0.0264sec
--- a/femtolisp/unittest.lsp
+++ /dev/null
@@ -1,274 +1,0 @@
-; -*- scheme -*-
-(define-macro (assert-fail expr . what)
- `(assert (trycatch (begin ,expr #f)
- (lambda (e) ,(if (null? what) #t
- `(eq? (car e) ',(car what)))))))
-
-(define (every-int n)
- (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
- (int64 n) (uint64 n)))
-
-(define (every-sint n)
- (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
-
-(define (each f l)
- (if (atom? l) ()
- (begin (f (car l))
- (each f (cdr l)))))
-
-(define (each^2 f l m)
- (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
-
-(define (test-lt a b)
- (each^2 (lambda (neg pos)
- (begin
- (eval `(assert (= -1 (compare ,neg ,pos))))
- (eval `(assert (= 1 (compare ,pos ,neg))))))
- a
- b))
-
-(define (test-eq a b)
- (each^2 (lambda (a b)
- (begin
- (eval `(assert (= 0 (compare ,a ,b))))))
- a
- b))
-
-(test-lt (every-sint -1) (every-int 1))
-(test-lt (every-int 0) (every-int 1))
-(test-eq (every-int 88) (every-int 88))
-(test-eq (every-sint -88) (every-sint -88))
-
-(define (test-square a)
- (each (lambda (i) (eval `(assert (>= (* ,i ,i) 0))))
- a))
-
-(test-square (every-sint -67))
-(test-square (every-int 3))
-(test-square (every-int 0x80000000))
-(test-square (every-sint 0x80000000))
-(test-square (every-sint -0x80000000))
-
-(assert (= (* 128 0x02000001) 0x100000080))
-
-(assert (= (/ 1) 1))
-(assert (= (/ -1) -1))
-(assert (= (/ 2.0) 0.5))
-
-(assert (= (- 4999950000 4999941999) 8001))
-
-(assert (not (eqv? 10 #\newline)))
-(assert (not (eqv? #\newline 10)))
-
-; tricky cases involving INT_MIN
-(assert (< (- #uint32(0x80000000)) 0))
-(assert (> (- #int32(0x80000000)) 0))
-(assert (< (- #uint64(0x8000000000000000)) 0))
-(assert (> (- #int64(0x8000000000000000)) 0))
-
-(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
-(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
-(assert (equal? (* 2 #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
-
-(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
-
-(assert (equal? (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
-
-; NaNs
-(assert (equal? +nan.0 +nan.0))
-(assert (not (= +nan.0 +nan.0)))
-(assert (not (= +nan.0 -nan.0)))
-(assert (equal? (< +nan.0 3) (> 3 +nan.0)))
-(assert (equal? (< +nan.0 (double 3)) (> (double 3) +nan.0)))
-(assert (equal? (< +nan.0 3) (> (double 3) +nan.0)))
-(assert (equal? (< +nan.0 (double 3)) (> 3 +nan.0)))
-(assert (equal? (< +nan.0 3) (< +nan.0 (double 3))))
-(assert (equal? (> +nan.0 3) (> +nan.0 (double 3))))
-(assert (equal? (< 3 +nan.0) (> +nan.0 (double 3))))
-(assert (equal? (> 3 +nan.0) (> (double 3) +nan.0)))
-(assert (not (>= +nan.0 +nan.0)))
-
-; -0.0 etc.
-(assert (not (equal? 0.0 0)))
-(assert (equal? 0.0 0.0))
-(assert (not (equal? -0.0 0.0)))
-(assert (not (equal? -0.0 0)))
-(assert (not (eqv? 0.0 0)))
-(assert (not (eqv? -0.0 0)))
-(assert (not (eqv? -0.0 0.0)))
-(assert (= 0.0 -0.0))
-
-; this crashed once
-(for 1 10 (lambda (i) 0))
-
-; failing applications
-(assert-fail ((lambda (x) x) 1 2))
-(assert-fail ((lambda (x) x)))
-(assert-fail ((lambda (x y . z) z) 1))
-(assert-fail (car 'x) type-error)
-(assert-fail gjegherqpfdf___trejif unbound-error)
-
-; long argument lists
-(assert (= (apply + (iota 100000)) 4999950000))
-(define ones (map (lambda (x) 1) (iota 80000)))
-(assert (= (eval `(if (< 2 1)
- (+ ,@ones)
- (+ ,@(cdr ones))))
- 79999))
-
-(define MAX_ARGS 255)
-
-(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1))))
-(define f (compile `(lambda ,as ,(lastcdr as))))
-(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))
-(assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
-(assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
-
-(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
-(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
- ,(car (last-pair as)))))
-(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
-(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
- (lambda () ,(car (last-pair as))))))
-(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
-
-(define as (map-int (lambda (x) (gensym)) 1000))
-(define f (compile `(lambda ,as ,(car (last-pair as)))))
-(assert (equal? (apply f (iota 1000)) 999))
-
-(define as (apply list* (map-int (lambda (x) (gensym)) 995)))
-(define f (compile `(lambda ,as ,(lastcdr as))))
-(assert (equal? (apply f (iota 994)) '()))
-(assert (equal? (apply f (iota 995)) '(994)))
-(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
-
-; optional arguments
-(assert (equal? ((lambda ((b 0)) b)) 0))
-(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
-(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
-(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ())))
-(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
-
-; keyword arguments
-(assert (keyword? kw:))
-(assert (not (keyword? 'kw)))
-(assert (not (keyword? ':)))
-(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
- '(1 0 0 (8 4 5))))
-(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
- '(0 2 3 (1))))
-(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
-(assert (equal? (keys4 a: 10) '(10 3 7 6)))
-(assert (equal? (keys4 b: 10) '(8 10 7 6)))
-(assert (equal? (keys4 c: 10) '(8 3 10 6)))
-(assert (equal? (keys4 d: 10) '(8 3 7 10)))
-(assert-fail (keys4 e: 10)) ; unsupported keyword
-(assert-fail (keys4 a: 1 b:)) ; keyword with no argument
-
-; cvalues and arrays
-(assert (equal? (typeof "") '(array byte)))
-(assert-fail (aref #(1) 3) bounds-error)
-(define iarr (array 'int64 32 16 8 7 1))
-(assert (equal? (aref iarr 0) 32))
-(assert (equal? (aref iarr #int8(3)) 7))
-
-; gensyms
-(assert (gensym? (gensym)))
-(assert (not (gensym? 'a)))
-(assert (not (eq? (gensym) (gensym))))
-(assert (not (equal? (string (gensym)) (string (gensym)))))
-(let ((gs (gensym))) (assert (eq? gs gs)))
-
-; eof object
-(assert (eof-object? (eof-object)))
-(assert (not (eof-object? 1)))
-(assert (not (eof-object? 'a)))
-(assert (not (eof-object? '())))
-(assert (not (eof-object? #f)))
-(assert (not (null? (eof-object))))
-(assert (not (builtin? (eof-object))))
-(assert (not (function? (eof-object))))
-
-; ok, a couple end-to-end tests as well
-(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-(assert (equal? (fib 20) 6765))
-
-(load "color.lsp")
-(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
- '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))))
-
-; hashing strange things
-(assert (equal?
- (hash '#0=(1 1 #0# . #0#))
- (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
-
-(assert (not (equal?
- (hash '#0=(1 1 #0# . #0#))
- (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
-
-(assert (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
-
-(assert (not (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
-
-(assert (not (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
-
-(assert (equal?
- (hash '(#0=(#0#) 0))
- (hash '(#1=(((((#1#))))) 0))))
-
-(assert (not (equal?
- (hash '(#0=(#0#) 0))
- (hash '(#1=(((((#1#))))) 1)))))
-
-(assert (equal?
- (hash #0=[1 [2 [#0#]] 3])
- (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3])))
-
-(assert (not (equal?
- (hash #0=[1 [2 [#0#]] 3])
- (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3]))))
-
-(assert (equal?
- (hash #0=[1 #0# [2 [#0#]] 3])
- (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))
-
-(assert (not (equal?
- (hash #0=[1 #0# [2 [#0#]] 3])
- (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))))
-
-(assert (equal?
- (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])
- (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])))
-
-(assert (not (equal?
- (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3])
- (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3]))))
-
-(assert (equal? (hash '#0=(1 . #0#))
- (hash '#1=(1 1 . #1#))))
-
-(assert (not (equal? (hash '#0=(1 1 . #0#))
- (hash '#1=(1 #0# . #1#)))))
-
-(assert (not (equal? (hash (iota 10))
- (hash (iota 20)))))
-
-(assert (not (equal? (hash (iota 41))
- (hash (iota 42)))))
-
-(princ "all tests pass\n")
-#t