#||
SKI compiler
||#
(defmacro call (f &rest args) `(funcall ,f ,@args))
(defmacro define (form &body body)
(print form)
(cond ((consp form)
(cond ((consp (car form))
`(define ,(car form)
(lambda ,(cdr form) ,@body)))
(t `(progn (defmethod ,(car form) ,(cdr form)
,@body)
(defparameter ,(car form) (symbol-function ',(car form)))))))
(t `(progn (defparameter ,form ,(car body))
(when (functionp ,form)
(setf (symbol-function ',form) ,form))))))
(define (legendre x)
(+ 41 (+ x (* x x))))
(define (euler x)
(+ (- (* x x) x) 41))
(define ((f n) x) (- (- (* 3 x) 39) (* 3 n)))
(define (l2 n x) (legendre (call (f n) x)))
#||
Combinator reduction rules
[S f g x] = [[S f g] x] = [[[S f] g] x]
? (curry-exp '(lambda (x y) (if (< x y) x y)))
[C [B S [S [B C [B [B CIF] C<]] I]] I]
[C [B S [S [B C [B [B CIF] C<]] I]] I 3 5]
[[B S [S [B C [B [B CIF] C<]] I]] 3 [I 3] 5]
I x -> x, I == S K K Identity
K x y -> x Kestrel
S f g x -> f x (g x) Starling
B f g x -> f (g x) Bluebird
C f g x -> f x g Cardinal = curry second arg first.
T x f -> f x == C I x f Thrush
W f x -> f x x == S f I x Warbler
M x -> x x == S I I x Mocking Bird
S1 c f g x -> c (f x) (g x)
B1 c f g x -> c (f (g x))
C1 c f x -> c (f x) g
? (def (f x y) (flet (((s x) (+ x 1))) (* (s x) (s y))))
(C (B C (C (B B (B S (B (B *) THRUSH))) THRUSH)) (C + 1)) x y
(def (sq x y) (+ (* x y) x))
W (B C (B (B +) *)) x y ; dup
B C (B (B +) *) x x y
C ((B (B +) *) x) x y
B (B +) * x y x ; swap
B + (* x) y x
+ [* x y] x ; * +
x y
dup ; x x y
swap ; x y x
* ; (* x y)
+ ; (+ (* x y) x)
(def (f x y) (let ((z (+ x y))) (* z z)))
[B [B [W *]] +] x y
b [w *] [+ x] y
[w *] (+ x y)
(def (f x y) (+ (* x x) y))
[B + [W *] x y]
dup * +
[W [B C [B [B +] *]]]
S optimizations
S (K p) (K q) == K (p q)
S (K p) I == p
S (K p) (B q r) == B1 p q r
S (K p) q == B p q
S p I == W p
S (B p q) (K r) == C1 p q r
S p (K q) == C p q
S (B p q) r == S1 p q r
C I q == T q
abstract(f, x) :
abstract ([f1 f2], x) = Opt([S abstract(f1, x) abstract (f2, x)])
abstract (x, x) = I
abstract (c, x) = [K c] ; where c is not x.
||#
;;; An application: [f x]
(defclass app ()
((f :initarg f :accessor app-f)
(x :initarg x :accessor app-x)))
(define (app f x) (make-instance 'app 'f f 'x x))
(define (app? (a t)) nil)
(define (app? (a app)) t)
(define (clobber-app app result)
;; Clobber an app with is value.
(setf (app-f app) 'I
(app-x app) result)
result)
#+old
(define (print-app a s brakets?)
"Print applications left associatively."
(when brakets? (write-char #\( s))
(let ((f (app-f a)))
(if (app? f)
(PRINT-APP f s nil)
(print-object f s))
(write-char #\space s)
(print-object (app-x a) s)
(when brakets? (write-char #\) s))))
(define (print-app a s brakets?)
"Print applications left associatively."
(when brakets? (write-char #\[ s))
(let ((f (app-f a)))
(if (app? f)
(PRINT-APP f s nil)
(print-object f s))
(write-char #\space s)
(print-object (app-x a) s)
(when brakets? (write-char #\] s))))
(defmethod print-object ((a app) s) (print-app a s t))
(define (I? x) (eq x 'I))
(define (K? x) (and (app? x) (eq (app-f x) 'K)))
(define (k-x x) (app-x x))
#||
Currying rules
'x -> x
(lambda (x) e) -> abstract(curry(e), x)
(lambda (x ...) e) -> curry((lambda (x) (lambda (...) e)))
(if cond them else) -> [if curry(cond) curry(then) curry(else)]
(let ((arg val) ...) e) -> curry(((lambda (arg ...) e) val ...))
(flet (((f args body) ...) e) -> curry((let ((f (lambda args body)) ...) e))
(f x) -> [curry(f) (curry(x)]
(f x ...) -> curry(([f x] ...))
([f x] y ...) -> curry(([f x y] ...))
c -> c; if c is a constant
||#
(define (curry-exp (exp cons))
"Turn an expression, exp, into curried form."
(case (car exp)
((quote) (cadr exp))
((lambda) (curry-lambda (cadr exp) (caddr exp)))
((let) (curry-let (cadr exp) (caddr exp)))
((flet) (curry-flet (cadr exp) (caddr exp)))
(t (curry-call (car exp) (cdr exp)))))
(define (curry-exp (exp t)) exp)
(define (curry-lambda args body)
(abstract-args (curry-exp body) (reverse args)))
(define (curry-let args body)
(curry-exp `((lambda ,(mapcar #'car args) ,body)
,@(mapcar #'cadr args))))
36
(define (curry-flet fs body)
(curry-exp
`(let ,(mapcar
#+old #'(lambda (f) `(,(car f) (lambda ,(cadr f) ,(caddr f))))
#'(lambda (f) `(,(caar f) (lambda ,(cdar f) ,(cadr f))))
fs)
,body)))
(define (curry-call f args)
(if (null args) f
(curry-call (app (curry-exp f) (curry-exp (car args))) (cdr args))))
#||
||#
45
(defun abstract (exp var)
(if (eq exp var) 'I
(if (not (contains? exp var)) (app 'K exp)
(simplify-s (abstract (app-f exp) var)
(abstract (app-x exp) var)))))
(defun simplify-s (f g)
(cond ((and (K? f) (K? g)) (app 'K (app (k-x f) (k-x g))))
((and (K? f) (I? g)) (k-x f))
((K? f) (app (app 'B (k-x f)) g))
((K? g) (if (I? f) (app 'thrush (k-x g))
(app (app 'C f) (k-x g))))
((I? g) (app 'W f))
(t (app (app 'S f) g))))
(defun contains? (x y)
"Does expression X contain the variable Y?"
(if (app? x)
(or (contains? (app-f x) y) (contains? (app-x x) y))
(eq x y)))
60
(defun abstract-lambda (e)
(typecase e
(cons
(if (eq (car e) 'lambda)
(abstract (abstract-lambda (caddr e)) (car (cadr e)))
(app (abstract-lambda (app-f e)) (abstract-lambda (app-x e)))))
(t e)))
(define (abstract-args e args)
(if (null args) e
(abstract-args (abstract e (car args)) (cdr args))))
70
#||
Evaluation
||#
(defvar global-table (make-hash-table :size 100 :test #'eq))
(defsetf global-value (name) (v)
`(setf (gethash ,name global-table) ,v))
(define (global-value e)
(let ((it (gethash e global-table :no-value)))
(if (eq it :no-value)
(error "~a has no global value." e)
it)))
(defmacro def (name &body body)
(if (consp name)
(let ((name (car name))
(args (cdr name)))
`(install-def-function ',name '(lambda ,args ,@body)))
`(install-def-variable ',name ',(car body))))
(define (install-def-function name body)
(let ((it (curry-exp body)))
(print it)
;; (do-y it (list (cons name it)))
(setf (gethash name global-table) it)
name))
(define (install-def-variable name body)
(let ((it (curry-exp body)))
(print it)
(print (setf (gethash name global-table)
(ski-top it)))
name))
(defmacro top (e) `(top-1 ',e))
(define (top-1 e)
(let ((it (curry-exp e)))
(print it)
(let ((it (ski-top it)))
(print it)
(sprint it))))
103
#||
(define (do-y (e app) table)
(do-y-app-f (app-f e) e table)
(do-y-app-x (app-x e) e table))
(define (do-y (e t) table) e)
(define (do-y-app-f (f symbol) (e app) table)
(let ((it (assoc f table)))
(when (not (null it))
(setf (app-f e) (cdr it)))))
(define (do-y-app-f (f app) (e app) table)
(do-y f table))
(define (do-y-app-x (x app) (e app) table)
(do-y x table))
(define (do-y-app-x (x symbol) (e app) table)
(let ((it (assoc x table)))
(when (not (null it))
(setf (app-x e) (cdr it)))))
(define (do-y-app-x (x t) (e app) table))
||#
(define -s- (make-array 100 :adjustable t :fill-pointer 0))
(define (spush e stack)
(vector-push-extend e stack)
stack)
(define (spop stack) (vector-pop stack))
(define (sclear stack)
(setf (fill-pointer stack) 0)
stack)
110
(define (ski-top e)
;; Top level entry to the evaluator.
(seval e (sclear -s-)))
(defmacro ski (e)
`(ski-1 ,e))
(define (ski-1 e)
;; Top level evaluator of a single Lisp expression, e.
(let ((it (curry-exp e)))
(print it)
(ski-top it)))
(define (sprint (e t) s) (write e :stream s))
(define (sprint (e app) s) (sprint (ski-top e) s))
(define (sprint (e cons) s)
(write-char #\( s)
(sprint (car e) s)
(sprint-cdr (cdr e) s))
(define (sprint-cdr (e t) s)
;; (write-char #\space s)
(write-char #\. s)
(write-char #\space s)
(sprint e s)
(write-char #\) s))
(define (sprint-cdr (e cons) s)
(write-char #\space s)
(sprint (car e) s)
(sprint-cdr (cdr e) s))
(define (sprint-cdr (e app) s)
(sprint-cdr (ski-top e) s))
(define (sprint-cdr (e null) s)
(write-char #\) s))
134
#||
(ski '(flet ((s (x) (+ 1 s))) (s 2)))
||#
(define (seval (e app) stack) (seval (app-f e) (spush e stack)))
(define (seval (e symbol) stack) (seval (global-value e) stack))
;;; We use T and NIL for True and False, just to be like Lisp.
(define (seval (e (eql 'NIL)) (stack t)) NIL)
(define (seval (e (eql 'T)) (stack t)) T)
(define (seval (e t) (stack t)) e)
(defun scheck (n stack)
(unless (>= (length stack) n)
(error "scheck?")))
(define (seval-app (e function) stack) (call e stack))
;;; Eval an application's argument.
(define (sarg a stack) (seval (app-x a) stack))
(define (sarg a stack)
;; Eval an application's argument - Memoizing version
(let ((r (seval (app-x a) stack)))
(setf (app-x a) r)))
(define (scall-E op stack)
(scheck 1 stack)
(let* ((a (spop stack))
(r (call op (sarg a stack))))
(clobber-app a r)))
152
(define (E-scall-E op stack)
(scheck 1 stack)
(let* ((a (spop stack))
(r (seval (call op (sarg a stack)) stack)))
(clobber-app a r)))
(define (scall-LL op stack)
(scheck 2 stack)
(let* ((a (spop stack))
(b (spop stack))
(r (call op (app-x a) (app-x b))))
(clobber-app b r)))
(define (E-scall-LL op stack)
(scheck 2 stack)
(let* ((a (spop stack))
(b (spop stack))
(r (seval (call op (app-x a) (app-x b)) stack)))
(clobber-app b r)))
(define (scall-EE op stack)
(scheck 2 stack)
(let* ((a (spop stack))
(b (spop stack))
(r (call op (sarg a stack) (sarg b stack))))
(clobber-app b r)))
(define (E-scall-LLL op stack)
(scheck 3 stack)
(let* ((a (spop stack))
(b (spop stack))
(c (spop stack))
(r (seval (call op (app-x a) (app-x b) (app-x c)) stack)))
(clobber-app c r)))
(define (E-scall-ELL op stack)
(scheck 3 stack)
(let* ((cond (spop stack))
(then (spop stack))
(else (spop stack))
(r (seval (call op (sarg cond stack) (app-x then) (app-x else)) stack)))
(clobber-app else r)))
183
(define (scall-EL op stack)
(scheck 2 stack)
(let* ((x (spop stack))
(y (spop stack))
(r (call op (sarg x stack) y)))
(clobber-app y r)))
(define (seval (e (eql 'S)) stack)
;; S f g x -> f x (g x) Starling
(E-scall-LLL (lambda (f g x) (app (app f x) (app g x))) stack))
191
(define (seval (e (eql 'B)) stack)
;; B f g x -> f (g x) Bluebird = compose
(E-scall-LLL (lambda (f g x) (app f (app g x))) stack))
(define (seval (e (eql 'C)) stack)
;; C f g x -> f x g Cardinal = curry second arg first.
(E-scall-LLL (lambda (f g x) (app (app f x) g)) stack))
(define (seval (e (eql 'THRUSH)) stack)
;; T x f -> f x Thrush = reverse application.
(E-scall-LL (lambda (x f) (app f x)) stack))
(define (seval (e (eql 'W)) stack)
;; W f x -> f x x == S f I x Warbler = Duplicate argument.
(E-scall-LL (lambda (f x) (app (app f x) x)) stack))
(define (seval (e (eql 'I)) stack)
;; [I x] -> x == [S K K] Identity
(scall-E #'identity stack))
(define (seval (e (eql 'K)) stack)
;; [K x y] -> x Kestrel
(scall-EL (lambda (x y) y x) stack))
201
(define (seval (e (eql 'IF)) stack)
(E-scall-ELL (lambda (cond then else) (if cond then else)) stack))
(define (seval (e (eql '<)) stack) (scall-EE #'< stack))
(define (seval (e (eql '-)) stack) (scall-EE #'- stack))
(define (seval (e (eql '+)) stack) (scall-EE #'+ stack))
(define (seval (e (eql '*)) stack) (scall-EE #'* stack))
(define (seval (e (eql '/)) stack) (scall-EE #'truncate stack))
;;; We could define = in terms of <.
(define (seval (e (eql '=)) stack) (scall-EE #'= stack))
209
;;; Cons should not evaluate its arguments.
;;; The Sussman way would be scall-EL
(define (seval (e (eql 'cons)) stack) (scall-LL #'cons stack))
(define (seval (e (eql 'eql)) stack) (scall-EE #'eql stack))
;;; The Sussman way would be scall-E
(define (seval (e (eql 'car)) stack) (E-scall-E #'car stack))
(define (seval (e (eql 'cdr)) stack) (E-scall-E #'cdr stack))
(define (seval (e (eql 'mod)) stack) (scall-EE #'mod stack))
;;; Why isnt (- 0 x) good enough?
(define (seval (e (eql 'minus)) stack) (scall-E (lambda (x) (- x)) stack))
215
(def (from by i j)
(if (< i j) (cons i (from by (by i) j))
nil))
(def (null x) (eql nil x))
(def (filter p xs)
(if (null xs) nil
(let ((x (car xs)))
(if (= (mod x p) 0) (filter p (cdr xs))
(cons x (filter p (cdr xs)))))))
[B [S [C [B IF NULL] NIL]] [C [B S [S [B S [B [B S] [S [B B [B C [B [B IF] [C [B C [B [B =] [C MOD]]] 0]]]] [C [B B FILTER] CDR]]]] [B [B [C CONS]] [C [B B FILTER] CDR]]]] CAR]]
(def (seive xs)
(if (null xs) nil
(let ((it (car xs)))
(cons it (seive (filter it (cdr xs)))))))
[S [C [B IF NULL] NIL] [S [B [S CONS] [B [B SEIVE] [B [C FILTER] CDR]]] CAR]]
#||
? (ski '(cdr (cdr (cdr (from 1 5)))))
[CDR [CDR [CDR [FROM 1 5]]]]
([+ 1 [+ 1 [+ 1 1]]] . [B FROM [+ 1] [+ 1 [+ 1 [+ 1 1]]] 5])
||#