Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
A Nock Interpreter and Compiler in Common Lisp #Urbit
;; A nock interpreter
(defun tar (a f)
(labels ((fas (b a)
(declare (integer b))
(cond
((= b 1) a)
((= b 2) (car a))
((= b 3) (cdr a))
((evenp b) (car (fas (/ b 2) a)))
((oddp b) (cdr (fas (/ (1- (the integer b)) 2) a))))))
(if (consp (car f))
(cons
(tar a (car f))
(tar a (cdr f)))
(case (car f)
(0 (let ((b (cdr f)))
(fas b a)))
(1 (cdr f))
(2 (let ((b (cadr f))
(c (cddr f)))
(let ((x (tar a b))
(y (tar a c)))
(tar x y))))
(3 (let ((b (cdr f)))
(let ((x (tar a b)))
(if (consp x) 0 1))))
(4 (let ((b (cdr f)))
(let ((x (tar a b)))
(1+ (the integer x)))))
(5 (let ((b (cdr f)))
(let ((x (tar a b)))
(if (= (the integer (car x)) (the integer (cdr x))) 0 1))))
(6 (let ((b (cadr f))
(c (caddr f))
(d (cdddr f)))
(tar a `(2 (0 . 1) 2 (1 ,c . ,d) (1 . 0) 2
(1 2 . 3) (1 . 0) 4 4 . ,b))))
(7 (let ((b (cadr f))
(c (cddr f)))
(tar a `(2 ,b 1 . ,c))))
(8 (let ((b (cadr f))
(c (cddr f)))
(tar a `(7 ((7 (0 . 1) . ,b) 0 . 1) . ,c))))
(9 (let ((b (cadr f))
(c (cddr f)))
(tar a `(7 ,c 2 (0 . 1) 0 . ,b))))
))))
;; A nock compiler
(defun dao (f)
(declare (inline cons car cdr 1+))
(labels
((fas (b)
(declare (integer b))
(cond
((= b 1) 'a)
((= b 2) '(car a))
((= b 3) '(cdr a))
((evenp b) `(car ,(fas (/ b 2))))
((oddp b)
`(cdr ,(fas (/ (1- b) 2)))))))
(declare (inline fas))
(if (or (integerp f)
(symbolp f))
f
(if (consp (car f))
(let ((m (dao (car f)))
(n (dao (cdr f))))
`(cons ,m ,n))
(case (car f)
(0 (fas (cdr f)))
(1 (if (or (integerp (cdr f))
(symbolp (cdr f)))
(cdr f)
`',(cdr f)))
(2 (let ((bc (dao (cadr f)))
(d (dao (cddr f))))
(if (eq (car d) 'quote)
(let ((x (dao (cadr d))))
(if (or (eq bc 'a)
(integerp x))
x
`(let ((a ,bc))
,x)))
`(funcall (the function (phi ,d a)) ,bc))))
(3 `(if (consp ,(dao (cdr f))) 0 1))
(4 `(1+ (the integer ,(dao (cdr f)))))
(5 (destructuring-bind (m . n) (cdr f)
`(if (= ,(dao m) ,(dao n)) 0 1)))
(6 (let ((b (dao (cadr f)))
(c (dao (caddr f)))
(d (dao (cdddr f))))
`(if (= (the integer ,b) 0)
,c ,d)))
(7 (let ((b (dao (cadr f)))
(c (dao (cddr f))))
`(flet ((f (a) ,b)
(g (a) ,c))
(declare (inline f g))
(g (f a)))))
(8 (let ((b (dao (cadr f)))
(c (dao (cddr f))))
`(let ((a (cons ,b a)))
,c)))
(9
(let ((b (dao (cadr f)))
(c (dao (cddr f))))
`(flet ((f (a) ,c))
(declare (inline f))
(let ((x (f a)))
(funcall (the function
(phi (let ((a x))
,(fas b)))) x))))))
))))
;; A nock compiler driver
(defparameter cache (make-hash-table :test #'equal))
(defun phi (f &optional a)
(let ((compiled (gethash f cache)))
(if compiled
compiled
(let ((code `(lambda (a)
(declare (optimize (speed 3) (safety 0)))
,(dao f))))
(print code)
(setf (gethash f cache) (compile nil code))))))
#|
;; Running (dec 100.000.000)...
CL-USER> (time (tar 0 '(8 (8 (1 . 0) 8 (1 . 0) (1 6 (5 (4 0 . 14) 0 . 6) (0 . 14) 9 2 (0 . 2) (0 . 6) (4 0 . 14) 0 . 15) 0 . 1) 9 2 (0 . 4) (7 (0 . 3) 1 . 100000000) 0 . 11)))
Evaluation took:
154.804 seconds of real time
154.191088 seconds of total run time (151.147045 user, 3.044043 system)
[ Run times consist of 4.769 seconds GC time, and 149.423 seconds non-GC time. ]
99.60% CPU
433,556,434,319 processor cycles
195,199,995,456 bytes consed
99999999
CL-USER> (time (funcall (phi '(8 (8 (1 . 0) 8 (1 . 0) (1 6 (5 (4 0 . 14) 0 . 6) (0 . 14) 9 2 (0 . 2) (0 . 6) (4 0 . 14) 0 . 15) 0 . 1) 9 2 (0 . 4) (7 (0 . 3) 1 . 100000000) 0 . 11)) 0))
Evaluation took:
2.575 seconds of real time
2.563883 seconds of total run time (2.488210 user, 0.075673 system)
[ Run times consist of 0.093 seconds GC time, and 2.471 seconds non-GC time. ]
99.57% CPU
7,212,489,149 processor cycles
4,800,019,808 bytes consed
99999999
|#
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment