Skip to content

Instantly share code, notes, and snippets.

@agumonkey

agumonkey/e.el

Last active January 21, 2017 10:01
Show Gist options
  • Save agumonkey/46c7e86878046005cb428a3780f15518 to your computer and use it in GitHub Desktop.
Save agumonkey/46c7e86878046005cb428a3780f15518 to your computer and use it in GitHub Desktop.
Download ZIP
lisp in small pieces like CPS interpreter -- INCOMPLETE
Raw
e.el
;;; -*- lexical-binding: t -*-
(setq lexical-binding t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; BEGIN
(message "[log] begin")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; NULL EVAL
(defun e (r e)
(if (atom e)
(if (symbolp e) (funcall r e)
e)
(let ((k (car e)))
(cond ((eq k 'if) :if)
((eq k 'quo) :quo)
((eq k 'fun) :fun)
((eq k 'let) :let)
((eq k '+) (+ (e r (nth 1 e))
(e r (nth 2 e))))
(t :app)))))
(defun null-rho () (lambda (n) nil))
(defun rho (n v r) (lambda (m) (if (eq n m) v (funcall r m))))
(defun rhi (n v) (rho n v (null-rho)))
(funcall (rho 'a 1 (null-rho)) 'a)
(funcall (rho 'a 1 (null-rho)) 'b)
(funcall (rho 'a 1 (rho 'b 2 (null-rho))) 'b)
(e (null-rho) '(t 1 2))
(e (rhi 'x 1) '(+ x 10))
;;; +let
(defun e (r e)
(if (atom e)
(if (symbolp e) (funcall r e)
e)
(let ((k (car e)))
(cond ((eq k 'iff) :iff)
((eq k 'quo) :quo)
((eq k 'fun) :fun)
((eq k 'let) (e (rho (nth 1 e)
(e r (nth 2 e))
r)
(nth 3 e))) ; let n e b
((eq k '+) (+ (e r (nth 1 e))
(e r (nth 2 e))))
(t :app)))))
(e (rhi 'x 1) '(let y 10
(let z (+ x y)
(+ z z))))
;; 22
(defalias '@ 'funcall)
(defun e (r e c)
(if (atom e)
(@ c (if (symbolp e) (@ r e) e))
(let ((k (car e)))
(cond ((eq k 'iff) (@ c :iff))
((eq k 'quo) (@ c :quo))
((eq k 'fun) (@ c :fun))
((eq k 'let) (@ c (e (rho (nth 1 e) (e r (nth 2 e)) r)
(nth 3 e))))
;; ((eq k 'let) (@ c (e (rho (nth 1 e) (e r (nth 2 e)) r)
;; (nth 3 e)))) ; let n e b
((eq k '+)
;; (@ c (+ (e r (nth 1 e) c)
;; (e r (nth 2 e) c)))
(e r (nth 1 e)
(lambda (a)
(e r (nth 2 e)
(lambda (b)
(@ c (+ a b)))))))
(t (@ c :app))))))
(e (null-rho) '(+ 1 (+ 10 100)) (lambda (v) (message "-> %S" v)))
;;; OOOHHH ..
;;; binop works, but let is fake
;;; and let's write quo too.
;;; +quo
(defun e (r e c)
(if (atom e)
(@ c (if (symbolp e) (@ r e) e))
(let ((k (car e)))
(cond ((eq k 'iff) (@ c :iff))
((eq k 'quo) (@ c (nth 1 e)))
((eq k 'fun) (@ c :fun))
((eq k 'let) (e r (nth 2 e) (lambda (v)
(e (rho (nth 1 e) v r) (nth 3 e) c))))
((eq k '+) (e r (nth 1 e) (lambda (a)
(e r (nth 2 e) (lambda (b)
(@ c (+ a b)))))))
(t (@ c :app))))))
(defun bk (v) (message " -> %S" v))
(e (null-rho) '(let x 1 (let y 2 (+ x (+ y y)))) #'bk)
;;; YAY.
(e (null-rho) '(quo 1) #'bk)
;;; +iff
(defun e (r e c)
(if (atom e)
(@ c (if (symbolp e) (@ r e) e))
(let ((k (car e)))
(cond ((eq k 'iff) (e r (nth 1 e) (lambda (b)
(if (eq b :x)
(e r (nth 2 e) c)
(e r (nth 3 e) c)))))
((eq k 'quo) (@ c (nth 1 e)))
((eq k 'fun) (@ c :fun))
((eq k 'let) (e r (nth 2 e) (lambda (v)
(e (rho (nth 1 e) v r) (nth 3 e) c))))
((eq k '+) (e r (nth 1 e) (lambda (a)
(e r (nth 2 e) (lambda (b)
(@ c (+ a b)))))))
(t (@ c :app))))))
(e (null-rho) '(iff :x (+ 1 10) (+ 9 90)) #'bk)
;;; +clo
(defun clo (f r)
(list 'clo
(nth 1 f)
r
(nth 2 f)))
(defun e (r e c)
(if (atom e)
(@ c (if (symbolp e) (@ r e) e))
(let ((k (car e)))
(cond ((eq k 'iff) (e r (nth 1 e) (lambda (b)
(if (eq b :x)
(e r (nth 2 e) c)
(e r (nth 3 e) c)))))
((eq k 'quo) (@ c (nth 1 e)))
((eq k 'fun) (@ c (clo e r)))
((eq k 'ccc) (e r (nth 1 e) c))
((eq k 'let) (e r (nth 2 e) (lambda (v)
(e (rho (nth 1 e) v r) (nth 3 e) c))))
((eq k '+) (e r (nth 1 e) (lambda (a)
(e r (nth 2 e) (lambda (b)
(@ c (+ a b)))))))
(t (e r (nth 1 e) (lambda (v)
(e r (nth 0 e) (lambda (f)
(e (rho (nth 1 f) v (nth 2 f)) (nth 3 f) c)))))))))) ; (f e)
(e (null-rho) '(ccc (fun k (+ 1 1))) #'bk)
(e (null-rho) '(fun x (+ 1 x)) #'bk)
(e (rho 'y 2 (null-rho)) '(fun x (+ 1 x)) #'bk)
(e (null-rho) '((fun x (+ 1 x)) 10) #'bk)
;;; YAY
(e (null-rho) '((let x 1 (fun y (+ x y))) 100) #'bk)
;;; NOT YAY, need closures :FIXED
;;; So .. ccc ? again.
;;; Stuck; let's add begin
;;; +beg
(defun e (r e c)
(if (atom e)
(@ c (if (symbolp e) (@ r e) e))
(let ((k (car e)))
(cond ((eq k 'quo) (@ c (nth 1 e)))
((eq k 'fun) (@ c (clo e r)))
;;; ((eq k 'ccc) (e r (nth 1 e) c)) ; ccc (fun k (+ 1 (k 10)))
;; OMG .. callcc is some sort of cps eval identity
;; ccc (fun k ...) === ((fun k ... ) [c](fun v v)
;; ... almost there
((eq k 'ccc) (e r (nth 1 e) (lambda (f)
(e r (cons f '(fun x x)) c))))
((eq k 'beg) (if (= 1 (length (cdr e)))
(e r (nth 1 e) c)
(e r (nth 1 e) (lambda (_)
(e r (cons 'beg (cddr e)) c))))) ; unproper rewrap
((eq k 'let) (e r (nth 2 e) (lambda (v)
(e (rho (nth 1 e) v r) (nth 3 e) c))))
((eq k '+) (e r (nth 1 e) (lambda (a)
(e r (nth 2 e) (lambda (b)
(@ c (+ a b)))))))
((eq k 'iff) (e r (nth 1 e) (lambda (b)
(if (eq b :x)
(e r (nth 2 e) c)
(e r (nth 3 e) c)))))
(t (e r (nth 1 e) (lambda (v)
(e r (nth 0 e) (lambda (f)
(e (rho (nth 1 f) v (nth 2 f)) (nth 3 f) c))))))))))
(e (null-rho) '(beg (+ 0 1) (+ 2 3)) #'bk)
(e (null-rho) '(beg 1) #'bk)
(defmacro comment (&rest x)
`(message "[comment] <%s> '%S" (buffer-name) (quote ,x)))
(comment (e (null-rho) '(beg) #'bk)) ; wrong
;;; beg seems alright, except for (beg)
;; eva (var n) r k = k (r n)
;; eva (quo e) r k = k e
;; eva (if c t f) r k = (eva c r (\v (eva (if v t f) r k)))
;; eva (lam n b) r k = clo (lam n b)
;; eva ((lam n b) a) r k = eva b ...
(e (null-rho) '(ccc (fun k (k 1))) #'bk)
;;; nope
;;; +binop
(defun in (e s) (assoc e s))
(defun of (e s) (cdr (assoc e s)))
(defvar bins (list
(cons '+ #'+)
(cons '- #'-)
(cons '* #'*)
(cons '/ #'/)))
;; (if (in '+ bins) (@ (of '+ bins) 1 2))
;; E (... (ccc (fun k )) ...)
;; E (ccc ...) (... [] ...)
(defun e (r e c)
(if (atom e)
(@ c (cond ((booleanp e) e)
((symbolp e) (@ r e))
(t e)))
(let ((k (car e)))
(cond ((eq k 'quo) (@ c (nth 1 e)))
((eq k 'fun) (@ c (clo e r)))
;; ((eq k 'ccc) (e (rho k '(fun v v) r) (nth 1 e) c))
;; ((eq k 'ccc) (let* ((f (nth 1 e))
;; (N (nth 1 f))
;; (K (e r '(fun v v) c)))
;; (e (rho N K r) (nth 2 f) c)))
((eq k 'ccc) (e r (nth 1 e) (lambda (f)
(@ f c))))
((eq k 'beg) (if (= 1 (length (cdr e)))
(e r (nth 1 e) c)
(e r (nth 1 e) (lambda (_)
(e r (cons 'beg (cddr e)) c))))) ; unproper rewrap
((eq k 'let) (e r (nth 2 e) (lambda (v)
(e (rho (nth 1 e) v r) (nth 3 e) c))))
((in k bins) (e r (nth 1 e) (lambda (a)
(e r (nth 2 e) (lambda (b)
(@ c (@ (of k bins) a b)))))))
((eq k 'iff) (e r (nth 1 e) (lambda (b)
(if b
(e r (nth 2 e) c)
(e r (nth 3 e) c)))))
(t (e r (nth 1 e) (lambda (v)
(e r (nth 0 e) (lambda (f)
(e (rho (nth 1 f) v (nth 2 f)) (nth 3 f) c))))))))))
(e (null-rho) '(beg
(+ 1 1)
(let inc (fun x (+ 1 x))
(+ (inc 2)
(* 3 10))))
#'bk)
;;; +porcelain
(defun ev (e) (e (null-rho) e #'bk))
(ev '(+ 1 2 3))
(defmacro eva (e) `(ev (quote ,e)))
(eva (+ 1 2))
(eva (let truth t
(let not (fun b (iff b nil b))
(let inc (fun x (+ x 1))
(let x 1
(iff (not truth) x (inc x)))))))
(comment :bug (eva '(ccc (fun k 1))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; HOST
;;;
;;; apparently my issue is that I merged host and guest lambda expressions
;;; kinda like the emacs-lisp encoded environment ..
;;; so I can't pass an emacs-lisp encoded continuation to the interpreted layer
;;; I need to convert everything related to k into pure guest
;; (defun i (r f v c)
;; (e (rho (nth 1 f) v r) (nth 2 f) c))
;; (defun e (r e c)
;; (if (atom e)
;; (i r c (if (symbolp e) (@ r e) e) c)
;; (let ((k (car e)))
;; (cond ((eq k 'iff) (i c :iff))
;; ((eq k 'quo) (i c (nth 1 e)))
;; ((eq k 'fun) (i c :fun))
;; ((eq k 'let) (e r (nth 2 e) (lambda (v)
;; (e (rho (nth 1 e) v r) (nth 3 e) c))))
;; ((eq k '+) (e r (nth 1 e) (lambda (a)
;; (e r (nth 2 e) (lambda (b)
;; (i c (+ a b)))))))
;; (t (i r c :app c))))))
;; (comment :bug (e (null-rho) '1 '(fun x x)))
;; obviously wrong, cps loop
;;; +pro
;;; +ccc:ret
(defun e (r e c)
(if (atom e)
(@ c (cond ((booleanp e) e)
((symbolp e) (@ r e))
(t e)))
(let ((k (car e)))
(cond ((eq k 'quo) (@ c (nth 1 e)))
((eq k 'fun) (@ c (clo e r)))
;; syntax: c | ccc (fun n b) ~> ccc (clo n r b)
((eq k 'ccc) (e r (nth 1 e) (lambda (f)
(e (rho (nth 1 f) c (nth 2 f)) (nth 3 f) c))))
((eq k 'ret) (e r (nth 2 e) (lambda (v)
(@ (@ r (nth 1 e)) v))))
;; syntax: ret k e
((eq k 'beg) (if (= 1 (length (cdr e)))
(e r (nth 1 e) c)
(e r (nth 1 e) (lambda (_)
(e r (cons 'beg (cddr e)) c))))) ; unproper sequence rewrap
((eq k 'pro) (e* r (cdr e) c)) ; proper sequence
((eq k 'let) (e r (nth 2 e) (lambda (v)
(e (rho (nth 1 e) v r) (nth 3 e) c))))
((in k bins) (e r (nth 1 e) (lambda (a)
(e r (nth 2 e) (lambda (b)
(@ c (@ (of k bins) a b)))))))
((eq k 'iff) (e r (nth 1 e) (lambda (b)
(if b
(e r (nth 2 e) c)
(e r (nth 3 e) c)))))
(t (e r (nth 1 e) (lambda (v)
(e r (nth 0 e) (lambda (f)
(e (rho (nth 1 f) v (nth 2 f)) (nth 3 f) c))))))))))
;;; ...
(defun e* (r es c)
(cond ((= 0 (length es)) (@ c :nul))
((= 1 (length es)) (e r (car es) c))
;; (t (e* r (e r (car es)) (lambda (_) (e* r (cdr es) c))))
(t (e r (car es) (lambda (_) (e* r (cdr es) c))))
))
(eva (pro))
(eva (pro 1 2))
(e (null-rho) '((fun k (+ k k)) 1) #'bk)
(e (null-rho) '(let x 1 (ccc (fun j (ret j x)))) #'bk)
(e (null-rho) '(let x 10 (ccc (fun j (+ 1 (ret j x))))) #'bk)
(e (null-rho) '(ccc (fun j (+ 1 (ccc (fun k (+ 1 (ret k 10))))))) #'bk)
(e (null-rho) '(ccc (fun j (+ 1 (ccc (fun k (+ 1 (ret j 10))))))) #'bk)
(eva (ccc (fun j (+ 1 (ret j 10)))))
(eva (let x (ccc (fun l (+ 1 (ret l 10)))) (+ 1 x)))
(eva (let x (ccc (fun l (fun k (k l)))) x))
;; (clo k
;; (closure ((r closure (t) (n) nil)
;; (v closure ((k . let)
;; (c . bk)
;; (e let x (ccc (fun l (fun k (k l)))) x)
;; (r closure (t) (n) nil) t)
;; (v) (e (rho (nth 1 e) v r) (nth 3 e) c))
;; (n . l)
;; t) (m) (if (eq n m) v (funcall r m)))
;; (k l))
(eva (let x (ccc (fun l (fun k (k l)))) (x (fun i i))))
;; " -> (closure ((k . let)
;; (c . bk)
;; (e . (let x (ccc (fun l (fun k (k l)))) (x (fun i i))))
;; (r . (closure (t) (n) nil) t)
;; (v) (e (rho (nth 1 e) v r) (nth 3 e) c))"
;;; I HAVE FAUX CALL/CC !
;; wanted to have a cuter toplevel env function
;; (defun rho (&rest as)
;; (cond ((= 0 (length as)) (null-rho))
;; ((= 2 (length as)) (lambda (k) (if (eq k (nth 1 as))) (nth 2 as) ))
;; (t (error "invalid arguments" :rho as))))
;; (@ (rho 1 2) 1)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CCC FIX ?
(defun e (r e c)
(if (atom e)
(@ c (cond ((booleanp e) e)
((symbolp e) (@ r e))
(t e)))
(let ((k (car e)))
(cond ((eq k 'quo) (@ c (nth 1 e)))
((eq k 'fun) (@ c (clo e r)))
((eq k 'ccc) (e r (nth 1 e) (lambda (f)
(e (rho (nth 1 f) c (nth 2 f)) (nth 3 f) c))))
((eq k 'ret) (e r (nth 2 e) (lambda (v)
(@ (@ r (nth 1 e)) v))))
((eq k 'pro) (e* r (cdr e) c))
((eq k 'let) (e r (nth 2 e) (lambda (v)
(e (rho (nth 1 e) v r) (nth 3 e) c))))
((in k bins) (e r (nth 1 e) (lambda (a)
(e r (nth 2 e) (lambda (b)
(@ c (@ (of k bins) a b)))))))
((eq k 'iff) (e r (nth 1 e) (lambda (b)
(if b
(e r (nth 2 e) c)
(e r (nth 3 e) c)))))
(t (e r (nth 1 e) (lambda (v)
(e r (nth 0 e) (lambda (f)
(e (rho (nth 1 f) v (nth 2 f)) (nth 3 f) c))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END.
(message "[log] end")
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment