urbit/ares
1
1
Fork 0
mirror of https://github.com/urbit/ares.git synced 2024-12-23 13:25:03 +03:00
Code Issues Packages Projects Releases Wiki Activity

going to redo control stack

Browse Source
This commit is contained in:
Edward Amsden 2021-11-16 14:07:10 -05:00
parent 7249e7584c
commit eb79dd3929
No known key found for this signature in database
GPG Key ID: 548EDF608CA956F6
23 changed files with 4117 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
fifth-pass/nock-a.rkt Normal file
View File

@ -0,0 +1,106 @@
#lang racket
(require rackunit)
;; This is a naive, direct, structurally recursive interpretation of Nock according
;; to the nock specification, with cells represented as cons cells and atoms represented
;; as Racket natural numbers.
(define (nock-noun subject formula)
(match formula
([cons (cons (var b) (var c)) (var d)]
(cons (nock-noun subject (cons b c)) (nock-noun subject d)))
([cons 0 (var b)]
(nock-tree-find subject b))
([cons 1 (var b)]
b)
([cons 2 (cons (var b) (var c))]
(nock-noun (nock-noun subject b) (nock-noun subject c)))
([cons 3 (var b)]
(if (pair? (nock-noun subject b)) 0 1))
([cons 4 (var b)]
(+ 1 (nock-noun subject b)))
([cons 5 (cons (var b) (var c))]
(if (eqv? (nock-noun subject b) (nock-noun subject c)) 0 1))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(if (= 0 (nock-noun subject b))
(nock-noun subject c)
(nock-noun subject d)))
([cons 7 (cons (var b) (var c))]
(nock-noun (nock-noun subject b) c))
([cons 8 (cons (var b) (var c))]
(nock-noun (cons (nock-noun subject b) subject) c))
([cons 9 (cons (var b) (var c))]
(let
([core (nock-noun subject c)])
(nock-noun core (nock-tree-find core b))))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(nock-tree-edit (nock-noun subject c) b (nock-noun subject d)))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(let
([_ (nock-noun subject c)])
(nock-noun subject d)))
([cons 11 (cons (var b) (var c))]
(nock-noun subject c))))
(define nock-tree-find
(lambda (tree address)
(if (= address 1) tree
(if (even? address)
(car (nock-tree-find tree (quotient address 2)))
(cdr (nock-tree-find tree (quotient address 2)))))))
; # operator in nock spec: tree editing
(define nock-tree-edit
(lambda (subtree address tree)
(if (= address 1) subtree
(if (even? address)
(nock-tree-edit (cons subtree (nock-tree-find tree (+ address 1))) (quotient address 2) tree)
(nock-tree-edit (cons (nock-tree-find tree (- address 1)) subtree) (quotient address 2) tree)))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(check-equal? (nock-noun test-tree (get-0 nock-here)) test-tree "tree address 1")
(check-equal? (nock-noun test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-noun test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-noun test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-noun test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-noun 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-noun 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-noun test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-noun test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-noun 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-noun test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-noun test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-noun 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-noun 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-noun 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

121
fifth-pass/nock-b-scry.rkt Normal file
View File

@ -0,0 +1,121 @@
#lang racket
(require rackunit)
;; This interpreter adds to (a) handling for a stack of scry gates
;;
;; Thus, it implements "nock 12" from the ++mink metacircular Nock interpreter
;; This is necessary so that the system nock interpreter can be used to jet
;; ++mink, resulting in virtualized Nock computations.
(define (nock-noun subject formula gates)
(let*
[(recur-on-noun (lambda (subject formula)
(nock-noun subject formula gates)))
(recur-on-scry-gate (lambda (ref path)
(let*
[(gate (car gates))
(gates (cdr gates))
(core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))]
(nock-noun core (car core) gates))))]
(match formula
([cons (cons (var b) (var c)) (var d)]
(cons (recur-on-noun subject (cons b c)) (recur-on-noun subject d)))
([cons 0 (var b)]
(nock-tree-find subject b))
([cons 1 (var b)]
b)
([cons 2 (cons (var b) (var c))]
(recur-on-noun (recur-on-noun subject b) (recur-on-noun subject c)))
([cons 3 (var b)]
(if (pair? (recur-on-noun subject b)) 0 1))
([cons 4 (var b)]
(+ 1 (recur-on-noun subject b)))
([cons 5 (cons (var b) (var c))]
(if (eqv? (recur-on-noun subject b) (recur-on-noun subject c)) 0 1))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(if (= 0 (recur-on-noun subject b))
(recur-on-noun subject c)
(recur-on-noun subject d)))
([cons 7 (cons (var b) (var c))]
(recur-on-noun (recur-on-noun subject b) c))
([cons 8 (cons (var b) (var c))]
(recur-on-noun (cons (recur-on-noun subject b) subject) c))
([cons 9 (cons (var b) (var c))]
(let
([core (recur-on-noun subject c)])
(recur-on-noun core (nock-tree-find core b))))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(nock-tree-edit (recur-on-noun subject c) b (recur-on-noun subject d)))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(let
([_ (recur-on-noun subject c)])
(recur-on-noun subject d)))
([cons 11 (cons (var b) (var c))]
(recur-on-noun subject c))
([cons 12 (cons (var ref) (var path))]
(recur-on-scry-gate (recur-on-noun subject ref) (recur-on-noun subject path))))))
(define nock-tree-find
(lambda (tree address)
(if (= address 1) tree
(if (even? address)
(car (nock-tree-find tree (quotient address 2)))
(cdr (nock-tree-find tree (quotient address 2)))))))
; # operator in nock spec: tree editing
(define nock-tree-edit
(lambda (subtree address tree)
(if (= address 1) subtree
(if (even? address)
(nock-tree-edit (cons subtree (nock-tree-find tree (+ address 1))) (quotient address 2) tree)
(nock-tree-edit (cons (nock-tree-find tree (- address 1)) subtree) (quotient address 2) tree)))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '()))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

156
fifth-pass/nock-c-exceptions.rkt Normal file
View File

@ -0,0 +1,156 @@
#lang racket
(require rackunit)
;; This interpreter builds on (b) by adding an explicit exception-handling mechanism
;; in the form of an error continuation and a trace.
;;
;; Traces are updated by specific static hints for nock 11 paired with specific dynamic hints.
(define (nock-noun subject formula gates err-k trace)
(let*
[(recur-on-noun (lambda (subject formula)
(nock-noun subject formula gates err-k trace)))
(recur-on-noun-with-hint (lambda (subject formula hint)
(nock-noun subject formula gates err-k (cons hint trace))))
(recur-on-scry-gate (lambda (ref path)
(let*
[(gate (car (car gates)))
(err-k (car (cdr (car gates))))
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))]
(nock-noun core (car core) gates err-k trace))))]
(match formula
([cons (cons (var b) (var c)) (var d)]
(cons (recur-on-noun subject (cons b c)) (recur-on-noun subject d)))
([cons 0 (var b)]
(nock-tree-find subject b err-k trace))
([cons 1 (var b)]
b)
([cons 2 (cons (var b) (var c))]
(recur-on-noun (recur-on-noun subject b) (recur-on-noun subject c)))
([cons 3 (var b)]
(if (pair? (recur-on-noun subject b)) 0 1))
([cons 4 (var b)]
(+ 1 (recur-on-noun subject b)))
([cons 5 (cons (var b) (var c))]
(if (eqv? (recur-on-noun subject b) (recur-on-noun subject c)) 0 1))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(let
[(test (recur-on-noun subject b))]
(if (= 0 test)
(recur-on-noun subject c)
(if (= 1 test)
(recur-on-noun subject d)
(err-k (cons 2 trace))))))
([cons 7 (cons (var b) (var c))]
(recur-on-noun (recur-on-noun subject b) c))
([cons 8 (cons (var b) (var c))]
(recur-on-noun (cons (recur-on-noun subject b) subject) c))
([cons 9 (cons (var b) (var c))]
(let
([core (recur-on-noun subject c)])
(recur-on-noun core (nock-tree-find core b err-k trace))))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(nock-tree-edit (recur-on-noun subject c) b (recur-on-noun subject d) err-k trace))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(let
[(clue (recur-on-noun subject c))]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(recur-on-noun-with-hint subject d (cons b clue))
(recur-on-noun subject d))))
([cons 11 (cons (var b) (var c))]
(recur-on-noun subject c))
([cons 12 (cons (var ref) (var path))]
(let
[(result (recur-on-scry-gate (recur-on-noun subject ref) (recur-on-noun subject path)))]
(if (equal? 0 result)
; ~
(err-k (cons 1 (cdr path)))
(if (equal? 0 (car result))
(err-k (cons 2 (cons (cons (tas "hunk") (cons ref path)) trace)))
(cdr (cdr result)))))))))
(define nock-tree-find
(lambda (tree address err-k trace)
(if (= address 0)
(err-k (cons 2 trace))
(if (= address 1) tree
(if (even? address)
(car (nock-tree-find tree (quotient address 2) err-k trace))
(cdr (nock-tree-find tree (quotient address 2) err-k trace)))))))
; # operator in nock spec: tree editing
(define nock-tree-edit
(lambda (subtree address tree err-k trace)
(if (= address 0)
(err-k (cons 2 trace))
(if (= address 1) subtree
(if (even? address)
(nock-tree-edit (cons subtree (nock-tree-find tree (+ address 1) err-k trace)) (quotient address 2) tree err-k trace)
(nock-tree-edit (cons (nock-tree-find tree (- address 1) err-k trace) subtree) (quotient address 2) tree err-k trace))))))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
(define (test-err-k err)
(printf "Error: ~v" err)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

149
fifth-pass/nock-d-inline.rkt Normal file
View File

@ -0,0 +1,149 @@
#lang racket
(require rackunit)
;; This pass inlines top-level recursion helpers resulting in direct calls to `nock-noun`
(define (nock-noun subject formula gates err-k trace)
(match formula
([cons (cons (var b) (var c)) (var d)]
(cons (nock-noun subject (cons b c) gates err-k trace) (nock-noun subject d gates err-k trace)))
([cons 0 (var b)]
(nock-tree-find subject b err-k trace))
([cons 1 (var b)]
b)
([cons 2 (cons (var b) (var c))]
(nock-noun (nock-noun subject b gates err-k trace) (nock-noun subject c gates err-k trace) gates err-k trace))
([cons 3 (var b)]
(if (pair? (nock-noun subject b gates err-k trace)) 0 1))
([cons 4 (var b)]
(+ 1 (nock-noun subject b gates err-k trace)))
([cons 5 (cons (var b) (var c))]
(if (eqv? (nock-noun subject b gates err-k trace) (nock-noun subject c gates err-k trace)) 0 1))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(let
[(test (nock-noun subject b gates err-k trace))]
(if (= 0 test)
(nock-noun subject c gates err-k trace)
(if (= 1 test)
(nock-noun subject d gates err-k trace)
(err-k (cons 2 trace))))))
([cons 7 (cons (var b) (var c))]
(nock-noun (nock-noun subject b gates err-k trace) c gates err-k trace))
([cons 8 (cons (var b) (var c))]
(nock-noun (cons (nock-noun subject b gates err-k trace) subject) c gates err-k trace))
([cons 9 (cons (var b) (var c))]
(let
([core (nock-noun subject c gates err-k trace)])
(nock-noun core (nock-tree-find core b err-k trace) gates err-k trace)))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(nock-tree-edit (nock-noun subject c gates err-k trace) b (nock-noun subject d gates err-k trace) err-k trace))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(let
[(clue (nock-noun subject c))]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(nock-noun subject d gates err-k (cons (cons b clue) trace))
(nock-noun subject d gates err-k trace))))
([cons 11 (cons (var b) (var c))]
(nock-noun subject c gates err-k trace))
([cons 12 (cons (var ref) (var path))]
(let*
[(ref (nock-noun subject ref gates err-k trace))
(path (nock-noun subject path gates err-k trace))
(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(trace (cdr (cdr (car gates))))
(outer-trace trace)
(gates (cdr gates))
(core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))
(result (nock-noun core (car core) gates err-k trace))]
(if (equal? 0 result)
; ~
(outer-err-k (cons 1 (cdr path)))
(if (equal? 0 (car result))
(outer-err-k (cons 2 (cons (cons (tas "hunk") (cons ref path)) outer-trace)))
(cdr (cdr result))))))))
(define nock-tree-find
(lambda (tree address err-k trace)
(if (= address 0)
(err-k (cons 2 trace))
(if (= address 1) tree
(if (even? address)
(car (nock-tree-find tree (quotient address 2) err-k trace))
(cdr (nock-tree-find tree (quotient address 2) err-k trace)))))))
; # operator in nock spec: tree editing
(define nock-tree-edit
(lambda (subtree address tree err-k trace)
(if (= address 0)
(err-k (cons 2 trace))
(if (= address 1) subtree
(if (even? address)
(nock-tree-edit (cons subtree (nock-tree-find tree (+ address 1) err-k trace)) (quotient address 2) tree err-k trace)
(nock-tree-edit (cons (nock-tree-find tree (- address 1) err-k trace) subtree) (quotient address 2) tree err-k trace))))))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
(define (test-err-k err)
(printf "Error: ~v" err)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

163
fifth-pass/nock-e-optimize-edit.rkt Normal file
View File

@ -0,0 +1,163 @@
#lang racket
(require rackunit)
;; This pass optimizes the nock-tree-edit (and nock-tree-find) functions by reversing the atom
;; passed as an address
(define (nock-noun subject formula gates err-k trace)
(match formula
([cons (cons (var b) (var c)) (var d)]
(cons (nock-noun subject (cons b c) gates err-k trace) (nock-noun subject d gates err-k trace)))
([cons 0 (var b)]
(nock-tree-find subject b err-k trace))
([cons 1 (var b)]
b)
([cons 2 (cons (var b) (var c))]
(nock-noun (nock-noun subject b gates err-k trace) (nock-noun subject c gates err-k trace) gates err-k trace))
([cons 3 (var b)]
(if (pair? (nock-noun subject b gates err-k trace)) 0 1))
([cons 4 (var b)]
(+ 1 (nock-noun subject b gates err-k trace)))
([cons 5 (cons (var b) (var c))]
(if (eqv? (nock-noun subject b gates err-k trace) (nock-noun subject c gates err-k trace)) 0 1))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(let
[(test (nock-noun subject b gates err-k trace))]
(if (= 0 test)
(nock-noun subject c gates err-k trace)
(if (= 1 test)
(nock-noun subject d gates err-k trace)
(err-k (cons 2 trace))))))
([cons 7 (cons (var b) (var c))]
(nock-noun (nock-noun subject b gates err-k trace) c gates err-k trace))
([cons 8 (cons (var b) (var c))]
(nock-noun (cons (nock-noun subject b gates err-k trace) subject) c gates err-k trace))
([cons 9 (cons (var b) (var c))]
(let
([core (nock-noun subject c gates err-k trace)])
(nock-noun core (nock-tree-find core b err-k trace) gates err-k trace)))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(nock-tree-edit (nock-noun subject c gates err-k trace) b (nock-noun subject d gates err-k trace) err-k trace))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(let
[(clue (nock-noun subject c))]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(nock-noun subject d gates err-k (cons (cons b clue) trace))
(nock-noun subject d gates err-k trace))))
([cons 11 (cons (var b) (var c))]
(nock-noun subject c gates err-k trace))
([cons 12 (cons (var ref) (var path))]
(let*
[(ref (nock-noun subject ref gates err-k trace))
(path (nock-noun subject path gates err-k trace))
(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))
(result (nock-noun core (car core) gates err-k trace))]
(if (equal? 0 result)
; ~
(outer-err-k (cons 1 (cdr path)))
(if (equal? 0 (car result))
(outer-err-k (cons 2 (cons (cons (tas "hunk") (cons ref path)) outer-trace)))
(cdr (cdr result))))))))
(define (reverse-address address) (reverse-address-acc address 1))
(define (reverse-address-acc address reversed)
(if (= address 1)
reversed
(reverse-address-acc (arithmetic-shift address -1) (bitwise-ior (arithmetic-shift reversed 1) (bitwise-and address 1)))))
(define (nock-tree-find-reversed tree reversed)
(if (= reversed 1)
tree
(if (even? reversed)
(nock-tree-find-reversed (car tree) (arithmetic-shift reversed -1))
(nock-tree-find-reversed (cdr tree) (arithmetic-shift reversed -1)))))
(define (nock-tree-find tree address err-k trace)
(if (= address 0)
(err-k (cons 2 trace))
(nock-tree-find-reversed tree (reverse-address address))))
(define (nock-tree-edit-reversed subtree reversed tree)
(if (= reversed 1)
subtree
(if (even? reversed)
(cons (nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (car tree)) (cdr tree))
(cons (car tree) (nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (cdr tree))))))
; # operator in nock spec: tree editing
(define (nock-tree-edit subtree address tree err-k trace)
(if (= address 0)
(err-k (cons 2 trace))
(nock-tree-edit-reversed subtree (reverse-address address) tree)))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
(define (test-err-k err)
(printf "Error: ~v" err)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

208
fifth-pass/nock-f-cps.rkt Normal file
View File

@ -0,0 +1,208 @@
#lang racket
(require rackunit)
;; This interpreter is a translation of the interpreter in (e) into continuation-passing style (CPS).
;;
;; Rather than return a result, functions take a function (called a continuation) to which to pass
;; their result, and invoke it. This creates a linear sequence of invocations rather than nested expressions.
(define (nock-noun subject formula gates err-k trace)
(nock-noun-cps subject formula gates err-k trace empty-k))
(define (nock-noun-cps subject formula gates err-k trace k)
(match formula
([cons (cons (var b) (var c)) (var d)]
(nock-noun-cps subject (cons b c) gates err-k trace
(lambda (u)
(nock-noun-cps subject d gates err-k trace
(lambda (v)
(k (cons u v)))))))
([cons 0 (var b)]
(nock-tree-find subject b err-k trace k))
([cons 1 (var b)]
(k b))
([cons 2 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(nock-noun-cps subject c gates err-k trace
(lambda (v)
(nock-noun-cps u v gates err-k trace k))))))
([cons 3 (var b)]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(if (pair? u)
(k 0)
(k 1)))))
([cons 4 (var b)]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(k (+ 1 u)))))
([cons 5 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(nock-noun-cps subject c gates err-k trace
(lambda (v)
(if (eqv? u v)
(k 0)
(k 1)))))))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(if (= 0 u)
(nock-noun-cps subject c gates err-k trace k)
(if (= 1 u)
(nock-noun-cps subject d gates err-k trace k)
(err-k (cons 2 trace)))))))
([cons 7 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(nock-noun-cps u c gates err-k trace k))))
([cons 8 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(nock-noun-cps (cons u subject) c gates err-k trace k))))
([cons 9 (cons (var b) (var c))]
(nock-noun-cps subject c gates err-k trace
(lambda (u)
(nock-tree-find u b err-k trace
(lambda (v)
(nock-noun-cps u v gates err-k trace k))))))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(nock-noun-cps subject c gates err-k trace
(lambda (u)
(nock-noun-cps subject d gates err-k trace
(lambda (v)
(nock-tree-edit u b v err-k trace k))))))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(nock-noun-cps subject c gates err-k trace
(lambda (u)
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(nock-noun-cps subject d gates err-k (cons (cons b u) trace) k)
(nock-noun-cps subject d gates err-k trace k)))))
([cons 11 (cons (var b) (var c))]
(nock-noun-cps subject c gates err-k trace k))
([cons 12 (cons (var ref) (var path))]
(nock-noun-cps subject ref gates err-k trace
(lambda (u)
(nock-noun-cps subject path gates err-k trace
(lambda (v)
(let*
[(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons u v) (cdr (cdr gate)))))]
(nock-noun-cps core (car core) gates err-k trace
(lambda (w)
(if (equal? 0 w)
; ~
(outer-err-k (cons 1 (cdr v)))
(if (equal? 0 (car w))
(outer-err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) (outer-trace trace))))
(k (cdr (cdr w)))))))))))))))
(define (reverse-address address k) (reverse-address-acc address 1 k))
(define (reverse-address-acc address reversed k)
(if (= address 1)
(k reversed)
(reverse-address-acc (arithmetic-shift address -1) (bitwise-ior (arithmetic-shift reversed 1) (bitwise-and address 1)) k)))
(define (nock-tree-find-reversed tree reversed k)
(if (= reversed 1)
(k tree)
(if (even? reversed)
(nock-tree-find-reversed (car tree) (arithmetic-shift reversed -1) k)
(nock-tree-find-reversed (cdr tree) (arithmetic-shift reversed -1) k))))
(define (nock-tree-find tree address err-k trace k)
(if (= address 0)
(err-k (cons 2 trace))
(reverse-address address (lambda (u)
(nock-tree-find-reversed tree u k)))))
(define (nock-tree-edit-reversed subtree reversed tree k)
(if (= reversed 1)
(k subtree)
(if (even? reversed)
(nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (car tree) (lambda (u)
(k (cons u (cdr tree)))))
(nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (cdr tree) (lambda (u)
(k (cons (car tree) u)))))))
; # operator in nock spec: tree editing
(define (nock-tree-edit subtree address tree err-k trace k)
(if (= address 0)
(err-k (cons 2 trace))
(reverse-address address
(lambda (u)
(nock-tree-edit-reversed subtree u tree k)))))
(define (empty-k v) v)
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
(define (test-err-k err)
(printf "Error: ~v" err)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

209
fifth-pass/nock-g-explicit-apply.rkt Normal file
View File

@ -0,0 +1,209 @@
#lang racket
(require rackunit)
;; This interpreter adds an explicit function for applying continuations,
;; a necessary pre-requisite to closure conversion
(define (nock-noun subject formula gates err-k trace)
(nock-noun-cps subject formula gates err-k trace empty-k))
(define (nock-noun-cps subject formula gates err-k trace k)
(match formula
([cons (cons (var b) (var c)) (var d)]
(nock-noun-cps subject (cons b c) gates err-k trace
(lambda (u)
(nock-noun-cps subject d gates err-k trace
(lambda (v)
(apply-k k (cons u v)))))))
([cons 0 (var b)]
(nock-tree-find subject b err-k trace k))
([cons 1 (var b)]
(apply-k k b))
([cons 2 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(nock-noun-cps subject c gates err-k trace
(lambda (v)
(nock-noun-cps u v gates err-k trace k))))))
([cons 3 (var b)]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(if (pair? u)
(apply-k k 0)
(apply-k k 1)))))
([cons 4 (var b)]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(apply-k k (+ 1 u)))))
([cons 5 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(nock-noun-cps subject c gates err-k trace
(lambda (v)
(if (eqv? u v)
(apply-k k 0)
(apply-k k 1)))))))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(if (= 0 u)
(nock-noun-cps subject c gates err-k trace k)
(if (= 1 u)
(nock-noun-cps subject d gates err-k trace k)
(apply-err-k err-k (cons 2 trace)))))))
([cons 7 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(nock-noun-cps u c gates err-k trace k))))
([cons 8 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(lambda (u)
(nock-noun-cps (cons u subject) c gates err-k trace k))))
([cons 9 (cons (var b) (var c))]
(nock-noun-cps subject c gates err-k trace
(lambda (u)
(nock-tree-find u b err-k trace
(lambda (v)
(nock-noun-cps u v gates err-k trace k))))))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(nock-noun-cps subject c gates err-k trace
(lambda (u)
(nock-noun-cps subject d gates err-k trace
(lambda (v)
(nock-tree-edit u b v err-k trace k))))))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(nock-noun-cps subject c gates err-k trace
(lambda (u)
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(nock-noun-cps subject d gates err-k (cons (cons b u) trace) k)
(nock-noun-cps subject d gates err-k trace k)))))
([cons 11 (cons (var b) (var c))]
(nock-noun-cps subject c gates err-k trace k))
([cons 12 (cons (var ref) (var path))]
(nock-noun-cps subject ref gates err-k trace
(lambda (u)
(nock-noun-cps subject path gates err-k trace
(lambda (v)
(let*
[(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons u v) (cdr (cdr gate)))))]
(nock-noun-cps core (car core) gates err-k trace
(lambda (w)
(if (equal? 0 w)
; ~
(outer-err-k (cons 1 (cdr v)))
(if (equal? 0 (car w))
(outer-err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) outer-trace)))
(apply-k k (cdr (cdr w)))))))))))))))
(define (reverse-address address k) (reverse-address-acc address 1 k))
(define (reverse-address-acc address reversed k)
(if (= address 1)
(apply-k k reversed)
(reverse-address-acc (arithmetic-shift address -1) (bitwise-ior (arithmetic-shift reversed 1) (bitwise-and address 1)) k)))
(define (nock-tree-find-reversed tree reversed k)
(if (= reversed 1)
(apply-k k tree)
(if (even? reversed)
(nock-tree-find-reversed (car tree) (arithmetic-shift reversed -1) k)
(nock-tree-find-reversed (cdr tree) (arithmetic-shift reversed -1) k))))
(define (nock-tree-find tree address err-k trace k)
(if (= address 0)
(apply-err-k err-k (cons 2 trace))
(reverse-address address (lambda (u)
(nock-tree-find-reversed tree u k)))))
(define (nock-tree-edit-reversed subtree reversed tree k)
(if (= reversed 1)
(apply-k k subtree)
(if (even? reversed)
(nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (car tree) (lambda (u)
(apply-k k (cons u (cdr tree)))))
(nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (cdr tree) (lambda (u)
(apply-k k (cons (car tree) u)))))))
; # operator in nock spec: tree editing
(define (nock-tree-edit subtree address tree err-k trace k)
(if (= address 0)
(apply-err-k err-k (cons 2 trace))
(reverse-address address
(lambda (u)
(nock-tree-edit-reversed subtree u tree k)))))
(define (empty-k v) v)
(define (apply-k k x) (k x))
(define (apply-err-k err-k err) (err-k err))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
(define (test-err-k err)
(printf "Error: ~v" err)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

254
fifth-pass/nock-h-closure-convert.rkt Normal file
View File

@ -0,0 +1,254 @@
#lang racket
(require rackunit)
;; This interpreter removes all nested lambdas by converting them
;; into a tagged union, which is matched by the continuation-application
;; function to invoke the body of the lambda.
(define (nock-noun subject formula gates err-k trace)
(nock-noun-cps subject formula gates err-k trace empty-k))
(define (nock-noun-cps subject formula gates err-k trace k)
(match formula
([cons (cons (var b) (var c)) (var d)]
(nock-noun-cps subject (cons b c) gates err-k trace
(nock-cons-k-1 subject d gates err-k trace k)))
([cons 0 (var b)]
(nock-tree-find subject b err-k trace k))
([cons 1 (var b)]
(apply-k k b))
([cons 2 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(nock-2-k-1 subject c gates err-k trace k)))
([cons 3 (var b)]
(nock-noun-cps subject b gates err-k trace
(nock-3-k k)))
([cons 4 (var b)]
(nock-noun-cps subject b gates err-k trace
(nock-4-k k)))
([cons 5 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(nock-5-k-1 subject c gates err-k trace k)))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(nock-noun-cps subject b gates err-k trace
(nock-6-k subject c d gates err-k trace k)))
([cons 7 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(nock-7-k c gates err-k trace k)))
([cons 8 (cons (var b) (var c))]
(nock-noun-cps subject b gates err-k trace
(nock-8-k subject c gates err-k trace k)))
([cons 9 (cons (var b) (var c))]
(nock-noun-cps subject c gates err-k trace
(nock-9-k-1 b gates err-k trace k)))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(nock-noun-cps subject c gates err-k trace
(nock-10-k-1 subject d b gates err-k trace k)))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(nock-noun-cps subject c gates err-k trace
(nock-11-k subject b d gates err-k trace k)))
([cons 11 (cons (var b) (var c))]
(nock-noun-cps subject c gates err-k trace k))
([cons 12 (cons (var ref) (var path))]
(nock-noun-cps subject ref gates err-k trace
(nock-12-k-1 subject path gates err-k trace)))))
(define (reverse-address address k) (reverse-address-acc address 1 k))
(define (reverse-address-acc address reversed k)
(if (= address 1)
(apply-k k reversed)
(reverse-address-acc (arithmetic-shift address -1) (bitwise-ior (arithmetic-shift reversed 1) (bitwise-and address 1)) k)))
(define (nock-tree-find-reversed tree reversed k)
(if (= reversed 1)
(apply-k k tree)
(if (even? reversed)
(nock-tree-find-reversed (car tree) (arithmetic-shift reversed -1) k)
(nock-tree-find-reversed (cdr tree) (arithmetic-shift reversed -1) k))))
(define (nock-tree-find tree address err-k trace k)
(if (= address 0)
(apply-err-k err-k (cons 2 trace))
(reverse-address address (nock-tree-find-k tree k))))
(define (nock-tree-edit-reversed subtree reversed tree k)
(if (= reversed 1)
(apply-k k subtree)
(if (even? reversed)
(nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (car tree)
(nock-tree-edit-car-k tree k))
(nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (cdr tree)
(nock-tree-edit-cdr-k tree k)))))
; # operator in nock spec: tree editing
(define (nock-tree-edit subtree address tree err-k trace k)
(if (= address 0)
(apply-err-k err-k (cons 2 trace))
(reverse-address address
(nock-tree-edit-k subtree tree k))))
(define empty-k (list 'empty-k))
(define (nock-cons-k-1 subject d gates err-k trace k) (list 'nock-cons-k-2 subject d gates err-k trace k))
(define (nock-cons-k-2 u k) (list 'nock-cons-k-2 u k))
(define (nock-2-k-1 subject c gates err-k trace k) (list 'nock-2-k-1 subject c gates err-k trace k))
(define (nock-2-k-2 u gates err-k trace k) (list 'nock-2-k-2 u gates err-k trace k))
(define (nock-3-k k) (list 'nock-3-k k))
(define (nock-4-k k) (list 'nock-4-k k))
(define (nock-5-k-1 subject c gates err-k trace k) (list 'nock-5-k-1 subject c gates err-k trace k))
(define (nock-5-k-2 u k) (list 'nock-5-k-2 u k))
(define (nock-6-k subject c d gates err-k trace k) (list 'nock-6-k subject c d gates err-k trace k))
(define (nock-7-k c gates err-k trace k) (list 'nock-7-k c gates err-k trace k))
(define (nock-8-k subject c gates err-k trace k) (list 'nock-8-k subject c gates err-k trace k))
(define (nock-9-k-1 b gates err-k trace k) (list 'nock-9-k-1 b gates err-k trace k))
(define (nock-9-k-2 u gates err-k trace k) (list 'nock-9-k-2 u gates err-k trace k))
(define (nock-10-k-1 subject d b gates err-k trace k) (list 'nock-10-k-1 subject d b gates err-k trace k))
(define (nock-10-k-2 u b err-k trace k) (list 'nock-10-k-2 u b err-k trace k))
(define (nock-11-k subject b d gates err-k trace k) (list 'nock-11-k subject b d gates err-k trace k))
(define (nock-12-k-1 subject path gates err-k trace k) (list 'nock-12-k-1 subject path gates err-k trace k))
(define (nock-12-k-2 gates err-k trace u k) (list 'nock-12-k-2 gates err-k trace u k))
(define (nock-12-k-3 u v outer-err-k outer-trace k) (list 'nock-12-k u v outer-err-k outer-trace k))
(define (nock-tree-find-k tree k) (list 'nock-tree-find-k tree k))
(define (nock-tree-edit-car-k tree k) (list 'nock-tree-edit-car-k tree k))
(define (nock-tree-edit-cdr-k tree k) (list 'nock-tree-edit-cdr-k tree k))
(define (nock-tree-edit-k subtree tree k) (list 'nock-tree-edit-k subtree tree k))
(define (apply-k k x)
(match k
([list 'empty-k] x)
([list 'nock-cons-k-1 (var subject) (var d) (var gates) (var err-k) (var trace) (var k)]
(nock-noun-cps subject d gates err-k trace (nock-cons-k-2 x k)))
([list 'nock-cons-k-2 (var u) (var k^)] (apply-k k (cons u x)))
([list 'nock-2-k-1 (var subject) (var c) (var gates) (var err-k) (var trace) (var k)]
(nock-noun-cps subject c gates err-k trace (nock-2-k-2 x gates err-k trace k)))
([list 'nock-2-k-2 (var u) (var gates) (var err-k) (var trace) (var k)]
(nock-noun-cps u x gates err-k trace k))
([list 'nock-3-k (var k)]
(if (pair? x) (apply-k k 0) (apply-k k 1)))
([list 'nock-4-k (var k)]
(apply-k k (+ 1 x)))
([list 'nock-5-k-1 (var subject) (var c) (var gates) (var err-k) (var trace) (var k)]
(nock-noun-cps subject c gates err-k trace
(nock-5-k-2 x k)))
([list 'nock-5-k-2 (var u) (var k)]
(if (eqv? u x) (apply-k k 0) (apply-k k 1)))
([list 'nock-6-k (var subject) (var c) (var d) (var gates) (var err-k) (var trace) (var k)]
(if (= 0 x)
(nock-noun-cps subject c gates err-k trace k)
(if (= 1 x)
(nock-noun-cps subject d gates err-k trace k)
(apply-err-k err-k (cons 2 trace)))))
([list 'nock-7-k (var c) (var gates) (var err-k) (var trace) (var k)]
(nock-noun-cps x c gates err-k trace k))
([list 'nock-8-k (var subject) (var c) (var gates) (var err-k) (var trace) (var k)]
(nock-noun-cps (cons x subject) c gates err-k trace k))
([list 'nock-9-k-1 (var b) (var gates) (var err-k) (var trace) (var k)]
(nock-tree-find x b err-k trace
(nock-9-k-2 x gates err-k trace k)))
([list 'nock-9-k-2 (var u) (var gates) (var err-k) (var trace) (var k)]
(nock-noun-cps u x gates err-k trace k))
([list 'nock-10-k-1 (var subject) (var d) (var b) (var gates) (var err-k) (var trace) (var k)]
(nock-noun-cps subject d gates err-k trace (nock-10-k-2 x b err-k trace k)))
([list 'nock-10-k-2 (var u) (var b) (var err-k) (var trace) (var k)]
(nock-tree-edit u b x err-k trace k))
([list 'nock-11-k (var subject) (var b) (var d) (var gates) (var err-k) (var trace) (var k)]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(nock-noun-cps subject d gates err-k (cons (cons b x) trace) k)
(nock-noun-cps subject d gates err-k trace k)))
([list 'nock-12-k-1 (var subject) (var path) (var gates) (var err-k) (var trace)]
(nock-noun-cps subject path gates err-k trace
(nock-12-k-2 gates err-k trace x k)))
([list 'nock-12-k-2 (var gates) (var err-k) (var trace) (var u) (var k)]
(let*
[(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons u x) (cdr (cdr gate)))))]
(nock-noun-cps core (car core) gates err-k trace
(nock-12-k-3 u x outer-err-k outer-trace k))))
([list 'nock-12-k-3 (var u) (var v) (var outer-err-k) (var outer-trace) (var k)]
(if (equal? 0 x)
; ~
(outer-err-k (cons 1 (cdr v)))
(if (equal? 0 (car x))
(outer-err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) outer-trace)))
(apply-k k (cdr (cdr x))))))
([list 'nock-tree-edit-car-k (var tree) (var k)]
(apply-k k (cons x (cdr tree))))
([list 'nock-tree-edit-cdr-k (var tree) (var k)]
(apply-k k (cons (car tree) x)))
([list 'nock-tree-edit-k (var subtree) (var tree) (var k)]
(nock-tree-edit-reversed subtree x tree k))
([list 'nock-tree-find-k (var tree) (var k)]
(nock-tree-find-reversed tree x k))
((var k^) #:when (procedure? k^) (k^ x))))
(define (apply-err-k err-k err) (err-k err))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
(define (test-err-k err)
(printf "Error: ~v" err)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

297
fifth-pass/nock-i-k-stack.rkt Normal file
View File

@ -0,0 +1,297 @@
#lang racket
(require rackunit)
;; This interpreter converts the implicit stack of continuations from (j)
;; (represented by every continuation closure other than empty-k receiving
;; the current continuation as its last argument) into an explicit stack.
;;
;; It removes the continuation variable from all continuation closures
;; and adds a `push-k` operation to push a continuation closure onto the stack.
;;
;; The apply-k function now functions explicitly as a stack-popping operation.
(define stack '())
(define (push-k k)
(set! stack (cons k stack)))
(define (nock-noun subject formula gates err-k trace)
(begin
(push-k empty-k)
(nock-noun-cps subject formula gates err-k trace)))
(define (nock-noun-cps subject formula gates err-k trace)
(match formula
([cons (cons (var b) (var c)) (var d)]
(begin
(push-k (nock-cons-k-1 subject d gates err-k trace))
(nock-noun-cps subject (cons b c) gates err-k trace)))
([cons 0 (var b)]
(nock-tree-find subject b err-k trace))
([cons 1 (var b)]
(apply-k b))
([cons 2 (cons (var b) (var c))]
(begin
(push-k (nock-2-k-1 subject c gates err-k trace))
(nock-noun-cps subject b gates err-k trace)))
([cons 3 (var b)]
(begin
(push-k nock-3-k)
(nock-noun-cps subject b gates err-k trace)))
([cons 4 (var b)]
(begin
(push-k nock-4-k)
(nock-noun-cps subject b gates err-k trace)))
([cons 5 (cons (var b) (var c))]
(begin
(push-k (nock-5-k-1 subject c gates err-k trace))
(nock-noun-cps subject b gates err-k trace)))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(begin
(push-k (nock-6-k subject c d gates err-k trace))
(nock-noun-cps subject b gates err-k trace)))
([cons 7 (cons (var b) (var c))]
(begin
(push-k (nock-7-k c gates err-k trace))
(nock-noun-cps subject b gates err-k trace)))
([cons 8 (cons (var b) (var c))]
(begin
(push-k (nock-8-k subject c gates err-k trace))
(nock-noun-cps subject b gates err-k trace)))
([cons 9 (cons (var b) (var c))]
(begin
(push-k (nock-9-k-1 b gates err-k trace))
(nock-noun-cps subject c gates err-k trace)))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(begin
(push-k (nock-10-k-1 subject d b gates err-k trace))
(nock-noun-cps subject c gates err-k trace)))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(begin
(push-k (nock-11-k subject b d gates err-k trace))
(nock-noun-cps subject c gates err-k trace)))
([cons 11 (cons (var b) (var c))]
(nock-noun-cps subject c gates err-k trace))
([cons 12 (cons (var ref) (var path))]
(begin
(push-k (nock-12-k-1 subject path gates err-k trace))
(nock-noun-cps subject ref gates err-k trace)))))
(define (reverse-address address) (reverse-address-acc address 1))
(define (reverse-address-acc address reversed)
(if (= address 1)
(apply-k reversed)
(reverse-address-acc (arithmetic-shift address -1) (bitwise-ior (arithmetic-shift reversed 1) (bitwise-and address 1)))))
(define (nock-tree-find-reversed tree reversed)
(if (= reversed 1)
(apply-k tree)
(if (even? reversed)
(nock-tree-find-reversed (car tree) (arithmetic-shift reversed -1))
(nock-tree-find-reversed (cdr tree) (arithmetic-shift reversed -1)))))
(define (nock-tree-find tree address err-k trace)
(if (= address 0)
(apply-err-k err-k (cons 2 trace))
(begin
(push-k (nock-tree-find-k tree))
(reverse-address address))))
(define (nock-tree-edit-reversed subtree reversed tree)
(if (= reversed 1)
(apply-k subtree)
(if (even? reversed)
(begin
(push-k (nock-tree-edit-car-k tree))
(nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (car tree)))
(begin
(push-k (nock-tree-edit-cdr-k tree))
(nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (cdr tree))))))
; # operator in nock spec: tree editing
(define (nock-tree-edit subtree address tree err-k trace)
(if (= address 0)
(apply-err-k err-k (cons 2 trace))
(begin
(push-k (nock-tree-edit-k subtree tree))
(reverse-address address))))
(define empty-k (list 'empty-k))
(define (nock-cons-k-1 subject d gates err-k trace) (list 'nock-cons-k-2 subject d gates err-k trace))
(define (nock-cons-k-2 u) (list 'nock-cons-k-2 u))
(define (nock-2-k-1 subject c gates err-k trace) (list 'nock-2-k-1 subject c gates err-k trace))
(define (nock-2-k-2 u gates err-k trace) (list 'nock-2-k-2 u gates err-k trace))
(define nock-3-k (list 'nock-3-k))
(define nock-4-k (list 'nock-4-k))
(define (nock-5-k-1 subject c gates err-k trace) (list 'nock-5-k-1 subject c gates err-k trace))
(define (nock-5-k-2 u) (list 'nock-5-k-2 u))
(define (nock-6-k subject c d gates err-k trace) (list 'nock-6-k subject c d gates err-k trace))
(define (nock-7-k c gates err-k trace) (list 'nock-7-k c gates err-k trace))
(define (nock-8-k subject c gates err-k trace) (list 'nock-8-k subject c gates err-k trace))
(define (nock-9-k-1 b gates err-k trace) (list 'nock-9-k-1 b gates err-k trace))
(define (nock-9-k-2 u gates err-k trace) (list 'nock-9-k-2 u gates err-k trace))
(define (nock-10-k-1 subject d b gates err-k trace) (list 'nock-10-k-1 subject d b gates err-k trace))
(define (nock-10-k-2 u b err-k trace) (list 'nock-10-k-2 u b err-k trace))
(define (nock-11-k subject b d gates err-k trace) (list 'nock-11-k subject b d gates err-k trace))
(define (nock-12-k-1 subject path gates err-k trace) (list 'nock-12-k-1 subject path gates err-k trace))
(define (nock-12-k-2 gates err-k trace u) (list 'nock-12-k-2 gates err-k trace u))
(define (nock-12-k-3 u v outer-err-k outer-trace) (list 'nock-12-k u v outer-err-k outer-trace))
(define (nock-tree-find-k tree) (list 'nock-tree-find-k tree))
(define (nock-tree-edit-car-k tree) (list 'nock-tree-edit-car-k tree))
(define (nock-tree-edit-cdr-k tree) (list 'nock-tree-edit-cdr-k tree))
(define (nock-tree-edit-k subtree tree) (list 'nock-tree-edit-k subtree tree))
(define (apply-k x)
(let
[(k (car stack))]
(begin
(set! stack (cdr stack))
(match k
([list 'empty-k] x)
([list 'nock-cons-k-1 (var subject) (var d) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-cons-k-2 x))
(nock-noun-cps subject d gates err-k trace)))
([list 'nock-cons-k-2 (var u) (var k^)]
(apply-k (cons u x)))
([list 'nock-2-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-2-k-2 x gates err-k trace))
(nock-noun-cps subject c gates err-k trace)))
([list 'nock-2-k-2 (var u) (var gates) (var err-k) (var trace)]
(nock-noun-cps u x gates err-k trace))
([list 'nock-3-k]
(if (pair? x) (apply-k 0) (apply-k 1)))
([list 'nock-4-k]
(apply-k (+ 1 x)))
([list 'nock-5-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-5-k-2 x))
(nock-noun-cps subject c gates err-k trace)))
([list 'nock-5-k-2 (var u)]
(if (eqv? u x) (apply-k 0) (apply-k 1)))
([list 'nock-6-k (var subject) (var c) (var d) (var gates) (var err-k) (var trace)]
(if (= 0 x)
(nock-noun-cps subject c gates err-k trace)
(if (= 1 x)
(nock-noun-cps subject d gates err-k trace)
(apply-err-k err-k (cons 2 trace)))))
([list 'nock-7-k (var c) (var gates) (var err-k) (var trace)]
(nock-noun-cps x c gates err-k trace))
([list 'nock-8-k (var subject) (var c) (var gates) (var err-k) (var trace)]
(nock-noun-cps (cons x subject) c gates err-k trace))
([list 'nock-9-k-1 (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-9-k-2 x gates err-k trace))
(nock-tree-find x b err-k trace)))
([list 'nock-9-k-2 (var u) (var gates) (var err-k) (var trace)]
(nock-noun-cps u x gates err-k trace))
([list 'nock-10-k-1 (var subject) (var d) (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-10-k-2 x b err-k trace))
(nock-noun-cps subject d gates err-k trace)))
([list 'nock-10-k-2 (var u) (var b) (var err-k) (var trace)]
(nock-tree-edit u b x err-k trace))
([list 'nock-11-k (var subject) (var b) (var d) (var gates) (var err-k) (var trace)]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(nock-noun-cps subject d gates err-k (cons (cons b x) trace))
(nock-noun-cps subject d gates err-k trace)))
([list 'nock-12-k-1 (var subject) (var path) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-12-k-2 gates err-k trace x))
(nock-noun-cps subject path gates err-k trace)))
([list 'nock-12-k-2 (var gates) (var err-k) (var trace) (var u)]
(let*
[(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons u x) (cdr (cdr gate)))))]
(begin
(push-k (nock-12-k-3 u x outer-err-k outer-trace))
(nock-noun-cps core (car core) gates err-k trace))))
([list 'nock-12-k-3 (var u) (var v) (var outer-err-k) (var outer-trace)]
(if (equal? 0 x)
; ~
(outer-err-k (cons 1 (cdr v)))
(if (equal? 0 (car x))
(outer-err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) outer-trace)))
(apply-k (cdr (cdr x))))))
([list 'nock-tree-edit-car-k (var tree)]
(apply-k (cons x (cdr tree))))
([list 'nock-tree-edit-cdr-k (var tree)]
(apply-k (cons (car tree) x)))
([list 'nock-tree-edit-k (var subtree) (var tree)]
(nock-tree-edit-reversed subtree x tree))
([list 'nock-tree-find-k (var tree)]
(nock-tree-find-reversed tree x))
((var k^) #:when (procedure? k^) (k^ x))))))
(define (apply-err-k err-k err) (err-k err))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
(define (test-err-k err)
(printf "Error: ~v" err)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

571
fifth-pass/nock-j-registerize.rkt Normal file
View File

@ -0,0 +1,571 @@
#lang racket
(require rackunit)
;; This pass builds on the mutable state (the continuation stack) introduced in (i)
;; and adds mutable registers, which are updated by the `set-register` function.
;;
;; Procedures no longer take language-native arguments, but have an explicit convention
;; for the globally-defined registers in which they expect their arguments.
(define stack '())
(define (push-k k)
(set! stack (cons k stack)))
(define ra 0)
(define rb 0)
(define rc 0)
(define rd 0)
(define re 0)
(define (set-register register x)
(match register
('ra (set! ra x))
('rb (set! rb x))
('rc (set! rc x))
('rd (set! rd x))
('re (set! re x))))
; interface with non-CPS, non-registerized calling convention
(define (nock-noun subject formula gates err-k trace)
(begin
(push-k empty-k)
(set-register 'ra subject)
(set-register 'rb formula)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
; ra - subject
; rb - formula
; rc - gate stack
; rd - err continuation
; re - err trace
(define (nock-noun-cps)
(match rb
([cons (cons (var b) (var c)) (var d)]
(begin
(push-k (nock-cons-k-1 ra d rc rd re))
; ra already set
(set-register 'rb (cons b c))
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 0 (var b)]
(begin
; ra already set
(set-register 'rb b)
(set-register 'rc rd)
(set-register 'rd re)
(nock-tree-find)))
([cons 1 (var b)]
(begin
(set-register 'ra b)
(apply-k)))
([cons 2 (cons (var b) (var c))]
(begin
(push-k (nock-2-k-1 ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 3 (var b)]
(begin
(push-k nock-3-k)
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 4 (var b)]
(begin
(push-k nock-4-k)
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 5 (cons (var b) (var c))]
(begin
(push-k (nock-5-k-1 ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(begin
(push-k (nock-6-k ra c d rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 7 (cons (var b) (var c))]
(begin
(push-k (nock-7-k c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 8 (cons (var b) (var c))]
(begin
(push-k (nock-8-k ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 9 (cons (var b) (var c))]
(begin
(push-k (nock-9-k-1 b rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(begin
(push-k (nock-10-k-1 ra d b rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(begin
(push-k (nock-11-k ra b d rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 11 (cons (var b) (var c))]
(begin
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 12 (cons (var ref) (var path))]
(begin
(push-k (nock-12-k-1 ra path rc rd re))
; ra already set
(set-register 'rb ref)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))))
; ra - address to reverse
(define (reverse-address)
(begin
; ra already set
(set-register 'rb 1)
(reverse-address-acc)))
; ra - address to reverse
; rb - accumulator for reversed address
(define (reverse-address-acc)
(if (= ra 1)
(begin
(set-register 'ra rb)
(apply-k))
(begin
(set-register 'rb (bitwise-ior (arithmetic-shift rb 1) (bitwise-and ra 1)))
(set-register 'ra (arithmetic-shift ra -1))
(reverse-address-acc))))
; ra - tree to find subtree of
; rb - reversed address to find
(define (nock-tree-find-reversed)
(if (= rb 1)
; ra already set
(apply-k)
(if (even? rb)
(begin
(set-register 'ra (car ra))
(set-register 'rb (arithmetic-shift rb -1))
(nock-tree-find-reversed))
(begin
(set-register 'ra (cdr ra))
(set-register 'rb (arithmetic-shift rb -1))
(nock-tree-find-reversed)))))
; ra - tree to find subtree of
; rb - address of subtree
; rc - err continuation
; rd - err trace
(define (nock-tree-find)
(if (= rb 0)
(begin
(set-register 'ra rc)
(set-register 'rb (cons 2 rd))
(apply-err-k))
(begin
(push-k (nock-tree-find-k ra))
(set-register 'ra rb)
(reverse-address))))
; ra - subtree to place at address
; rb - reversed address
; rc - tree to edit
(define (nock-tree-edit-reversed)
(if (= rb 1)
; ra already set
(apply-k)
(if (even? rb)
(begin
(push-k (nock-tree-edit-car-k rc))
; ra already set
(set-register 'rb (arithmetic-shift rb -1))
(set-register 'rc (car rc))
(nock-tree-edit-reversed))
(begin
(push-k (nock-tree-edit-cdr-k rc))
; ra already set
(set-register 'rb (arithmetic-shift rb -1))
(set-register 'rc (cdr rc))
(nock-tree-edit-reversed)))))
; # operator in nock spec: tree editing
; ra - subtree to place at address
; rb - address
; rc - tree to edit
; rd - err continuation
; re - err trace
(define (nock-tree-edit)
(if (= rb 0)
(begin
(set-register 'ra rd)
(set-register 'rb (cons 2 re))
(apply-err-k))
(begin
(push-k (nock-tree-edit-k ra rc))
(set-register 'ra rb)
(reverse-address))))
(define empty-k (list 'empty-k))
(define (nock-cons-k-1 subject d gates err-k trace) (list 'nock-cons-k-2 subject d gates err-k trace))
(define (nock-cons-k-2 u) (list 'nock-cons-k-2 u))
(define (nock-2-k-1 subject c gates err-k trace) (list 'nock-2-k-1 subject c gates err-k trace))
(define (nock-2-k-2 u gates err-k trace) (list 'nock-2-k-2 u gates err-k trace))
(define nock-3-k (list 'nock-3-k))
(define nock-4-k (list 'nock-4-k))
(define (nock-5-k-1 subject c gates err-k trace) (list 'nock-5-k-1 subject c gates err-k trace))
(define (nock-5-k-2 u) (list 'nock-5-k-2 u))
(define (nock-6-k subject c d gates err-k trace) (list 'nock-6-k subject c d gates err-k trace))
(define (nock-7-k c gates err-k trace) (list 'nock-7-k c gates err-k trace))
(define (nock-8-k subject c gates err-k trace) (list 'nock-8-k subject c gates err-k trace))
(define (nock-9-k-1 b gates err-k trace) (list 'nock-9-k-1 b gates err-k trace))
(define (nock-9-k-2 u gates err-k trace) (list 'nock-9-k-2 u gates err-k trace))
(define (nock-10-k-1 subject d b gates err-k trace) (list 'nock-10-k-1 subject d b gates err-k trace))
(define (nock-10-k-2 u b err-k trace) (list 'nock-10-k-2 u b err-k trace))
(define (nock-11-k subject b d gates err-k trace) (list 'nock-11-k subject b d gates err-k trace))
(define (nock-12-k-1 subject path gates err-k trace) (list 'nock-12-k-1 subject path gates err-k trace))
(define (nock-12-k-2 gates err-k trace u) (list 'nock-12-k-2 gates err-k trace u))
(define (nock-12-k-3 u v outer-err-k outer-trace) (list 'nock-12-k u v outer-err-k outer-trace))
(define (nock-tree-find-k tree) (list 'nock-tree-find-k tree))
(define (nock-tree-edit-car-k tree) (list 'nock-tree-edit-car-k tree))
(define (nock-tree-edit-cdr-k tree) (list 'nock-tree-edit-cdr-k tree))
(define (nock-tree-edit-k subtree tree) (list 'nock-tree-edit-k subtree tree))
; apply the continuation from the top of the stack
; ra - result
(define (apply-k)
(let
[(k (car stack))]
(begin
(set! stack (cdr stack))
(match k
([list 'empty-k] ra)
([list 'nock-cons-k-1 (var subject) (var d) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-cons-k-2 ra))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps subject d gates err-k trace)))
([list 'nock-cons-k-2 (var u) (var k^)]
(begin
(set-register 'ra (cons u ra))
(apply-k)))
([list 'nock-2-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-2-k-2 ra gates err-k trace))
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-2-k-2 (var u) (var gates) (var err-k) (var trace)]
(begin
(set-register 'rb ra)
(set-register 'ra u)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-3-k]
(if (pair? ra)
(begin
(set-register 'ra 0)
(apply-k))
(begin
(set-register 'ra 1)
(apply-k))))
([list 'nock-4-k]
(begin
(set-register 'ra (+ 1 ra))
(apply-k)))
([list 'nock-5-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-5-k-2 ra))
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-5-k-2 (var u)]
(if (eqv? u ra)
(begin
(set-register 'ra 0)
(apply-k))
(begin
(set-register 'ra 1)
(apply-k))))
([list 'nock-6-k (var subject) (var c) (var d) (var gates) (var err-k) (var trace)]
(if (= 0 ra)
(begin
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))
(if (= 1 ra)
(begin
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))
(begin
(set-register 'ra err-k)
(set-register 'rb (cons 2 trace))
(apply-err-k)))))
([list 'nock-7-k (var c) (var gates) (var err-k) (var trace)]
(begin
; ra already set
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-8-k (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(set-register 'ra (cons ra subject))
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-9-k-1 (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-9-k-2 ra gates err-k trace))
; ra already set
(set-register 'rb b)
(set-register 'rc err-k)
(set-register 'rd trace)
(nock-tree-find)))
([list 'nock-9-k-2 (var u) (var gates) (var err-k) (var trace)]
(begin
(set-register 'rb ra)
(set-register 'ra u)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-10-k-1 (var subject) (var d) (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-10-k-2 ra b err-k trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-10-k-2 (var u) (var b) (var err-k) (var trace)]
(begin
(set-register 'rc ra)
(set-register 'ra u)
(set-register 'rb b)
(set-register 'rd err-k)
(set-register 're trace)
(nock-tree-edit)))
([list 'nock-11-k (var subject) (var b) (var d) (var gates) (var err-k) (var trace)]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(begin
(set-register 're (cons (cons b ra) trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(nock-noun-cps))
(begin
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))))
([list 'nock-12-k-1 (var subject) (var path) (var gates) (var err-k) (var trace)]
(begin
(push-k (nock-12-k-2 gates err-k trace ra))
(set-register 'ra subject)
(set-register 'rb path)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-12-k-2 (var gates) (var err-k) (var trace) (var u)]
(let*
[(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons u ra) (cdr (cdr gate)))))]
(begin
(push-k (nock-12-k-3 u ra outer-err-k outer-trace))
(set-register 'ra core)
(set-register 'rb (car core))
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))))
([list 'nock-12-k-3 (var u) (var v) (var outer-err-k) (var outer-trace)]
(if (equal? 0 ra)
; ~
(begin
(set-register 'ra outer-err-k)
(set-register 'rb (cons 1 (cdr v)))
(apply-err-k))
(if (equal? 0 (car ra))
(begin
(set-register 'ra outer-err-k)
(set-register 'rb (cons 2 (cons (cons (tas "hunk") (cons u v)) outer-trace)))
(apply-err-k))
(begin
(set-register 'ra (cdr (cdr ra)))
(apply-k)))))
([list 'nock-tree-edit-car-k (var tree)]
(begin
(set-register 'ra (cons ra (cdr tree)))
(apply-k)))
([list 'nock-tree-edit-cdr-k (var tree)]
(begin
(set-register 'ra (cons (car tree) ra))
(apply-k)))
([list 'nock-tree-edit-k (var subtree) (var tree)]
(begin
(set-register 'rb ra)
(set-register 'ra subtree)
(set-register 'rc tree)
(nock-tree-edit-reversed)))
([list 'nock-tree-find-k (var tree)]
(begin
(set-register 'rb ra)
(set-register 'ra tree)
(nock-tree-find-reversed)))
((var k^) #:when (procedure? k^) (k^ ra))))))
; ra - err continuation
; rb - err trace
(define (apply-err-k) (ra))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
; rb - err trace
(define (test-err-k)
(printf "Error: ~v" ra)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

601
fifth-pass/nock-k-separate-control-stack.rkt Normal file
View File

@ -0,0 +1,601 @@
#lang racket
(require rackunit)
;; This pass builds on the mutable state (the continuation stack) introduced in (i)
;; and adds mutable registers, which are updated by the `set-register` function.
;;
;; Procedures no longer take language-native arguments, but have an explicit convention
;; for the globally-defined registers in which they expect their arguments.
(define stack '())
(define (push-k-data k)
(set! stack (cons k stack)))
(define control-stack '())
(define (push-k-control k)
(set! control-stack (cons k control-stack)))
(define ra 0)
(define rb 0)
(define rc 0)
(define rd 0)
(define re 0)
(define (set-register register x)
(match register
('ra (set! ra x))
('rb (set! rb x))
('rc (set! rc x))
('rd (set! rd x))
('re (set! re x))))
; interface with non-CPS, non-registerized calling convention
(define (nock-noun subject formula gates err-k trace)
(begin
(push-k-control 'empty-k)
(push-k-data empty-k)
(set-register 'ra subject)
(set-register 'rb formula)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
; ra - subject
; rb - formula
; rc - gate stack
; rd - err continuation
; re - err trace
(define (nock-noun-cps)
(match rb
([cons (cons (var b) (var c)) (var d)]
(begin
(push-k-control 'nock-cons-k-1)
(push-k-data (nock-cons-k-1 ra d rc rd re))
; ra already set
(set-register 'rb (cons b c))
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 0 (var b)]
(begin
; ra already set
(set-register 'rb b)
(set-register 'rc rd)
(set-register 'rd re)
(nock-tree-find)))
([cons 1 (var b)]
(begin
(set-register 'ra b)
(apply-k)))
([cons 2 (cons (var b) (var c))]
(begin
(push-k-control 'nock-2-k-1)
(push-k-data (nock-2-k-1 ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 3 (var b)]
(begin
(push-k-control 'nock-3-k)
(push-k-data nock-3-k)
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 4 (var b)]
(begin
(push-k-control 'nock-4-k)
(push-k-data nock-4-k)
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 5 (cons (var b) (var c))]
(begin
(push-k-control 'nock-5-k-1)
(push-k-data (nock-5-k-1 ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(begin
(push-k-control 'nock-6-k)
(push-k-data (nock-6-k ra c d rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 7 (cons (var b) (var c))]
(begin
(push-k-control 'nock-7-k)
(push-k-data (nock-7-k c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 8 (cons (var b) (var c))]
(begin
(push-k-control 'nock-8-k)
(push-k-data (nock-8-k ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 9 (cons (var b) (var c))]
(begin
(push-k-control 'nock-9-k-1)
(push-k-data (nock-9-k-1 b rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(begin
(push-k-control 'nock-10-k-1)
(push-k-data (nock-10-k-1 ra d b rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(begin
(push-k-control 'nock-11-k)
(push-k-data (nock-11-k ra b d rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 11 (cons (var b) (var c))]
(begin
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 12 (cons (var ref) (var path))]
(begin
(push-k-control 'nock-12-k-1)
(push-k-data (nock-12-k-1 ra path rc rd re))
; ra already set
(set-register 'rb ref)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))))
; ra - address to reverse
(define (reverse-address)
(begin
; ra already set
(set-register 'rb 1)
(reverse-address-acc)))
; ra - address to reverse
; rb - accumulator for reversed address
(define (reverse-address-acc)
(if (= ra 1)
(begin
(set-register 'ra rb)
(apply-k))
(begin
(set-register 'rb (bitwise-ior (arithmetic-shift rb 1) (bitwise-and ra 1)))
(set-register 'ra (arithmetic-shift ra -1))
(reverse-address-acc))))
; ra - tree to find subtree of
; rb - reversed address to find
(define (nock-tree-find-reversed)
(if (= rb 1)
; ra already set
(apply-k)
(if (even? rb)
(begin
(set-register 'ra (car ra))
(set-register 'rb (arithmetic-shift rb -1))
(nock-tree-find-reversed))
(begin
(set-register 'ra (cdr ra))
(set-register 'rb (arithmetic-shift rb -1))
(nock-tree-find-reversed)))))
; ra - tree to find subtree of
; rb - address of subtree
; rc - err continuation
; rd - err trace
(define (nock-tree-find)
(if (= rb 0)
(begin
(set-register 'ra rc)
(set-register 'rb (cons 2 rd))
(apply-err-k))
(begin
(push-k-control 'nock-tree-find-k)
(push-k-data (nock-tree-find-k ra))
(set-register 'ra rb)
(reverse-address))))
; ra - subtree to place at address
; rb - reversed address
; rc - tree to edit
(define (nock-tree-edit-reversed)
(if (= rb 1)
; ra already set
(apply-k)
(if (even? rb)
(begin
(push-k-control 'nock-tree-edit-car-k)
(push-k-data (nock-tree-edit-car-k rc))
; ra already set
(set-register 'rb (arithmetic-shift rb -1))
(set-register 'rc (car rc))
(nock-tree-edit-reversed))
(begin
(push-k-control 'nock-tree-edit-cdr-k)
(push-k-data (nock-tree-edit-cdr-k rc))
; ra already set
(set-register 'rb (arithmetic-shift rb -1))
(set-register 'rc (cdr rc))
(nock-tree-edit-reversed)))))
; # operator in nock spec: tree editing
; ra - subtree to place at address
; rb - address
; rc - tree to edit
; rd - err continuation
; re - err trace
(define (nock-tree-edit)
(if (= rb 0)
(begin
(set-register 'ra rd)
(set-register 'rb (cons 2 re))
(apply-err-k))
(begin
(push-k-control 'nock-tree-edit-k)
(push-k-data (nock-tree-edit-k ra rc))
(set-register 'ra rb)
(reverse-address))))
(define empty-k '())
(define (nock-cons-k-1 subject d gates err-k trace) (list subject d gates err-k trace))
(define (nock-cons-k-2 u) (list u))
(define (nock-2-k-1 subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-2-k-2 u gates err-k trace) (list u gates err-k trace))
(define nock-3-k '())
(define nock-4-k '())
(define (nock-5-k-1 subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-5-k-2 u) (list u))
(define (nock-6-k subject c d gates err-k trace) (list subject c d gates err-k trace))
(define (nock-7-k c gates err-k trace) (list c gates err-k trace))
(define (nock-8-k subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-9-k-1 b gates err-k trace) (list b gates err-k trace))
(define (nock-9-k-2 u gates err-k trace) (list u gates err-k trace))
(define (nock-10-k-1 subject d b gates err-k trace) (list subject d b gates err-k trace))
(define (nock-10-k-2 u b err-k trace) (list u b err-k trace))
(define (nock-11-k subject b d gates err-k trace) (list subject b d gates err-k trace))
(define (nock-12-k-1 subject path gates err-k trace) (list subject path gates err-k trace))
(define (nock-12-k-2 gates err-k trace u) (list gates err-k trace u))
(define (nock-12-k-3 u v outer-err-k outer-trace) (list u v outer-err-k outer-trace))
(define (nock-tree-find-k tree) (list tree))
(define (nock-tree-edit-car-k tree) (list tree))
(define (nock-tree-edit-cdr-k tree) (list tree))
(define (nock-tree-edit-k subtree tree) (list subtree tree))
; apply the continuation from the top of the stack
; ra - result
(define (apply-k)
(let
[(data (car stack))
(k (car control-stack))]
(begin
(set! stack (cdr stack))
(set! control-stack (cdr control-stack))
(match (cons k data)
([list 'empty-k] ra)
([list 'nock-cons-k-1 (var subject) (var d) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-cons-k-2)
(push-k-data (nock-cons-k-2 ra))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-cons-k-2 (var u) (var k^)]
(begin
(set-register 'ra (cons u ra))
(apply-k)))
([list 'nock-2-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-2-k-2)
(push-k-data (nock-2-k-2 ra gates err-k trace))
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-2-k-2 (var u) (var gates) (var err-k) (var trace)]
(begin
(set-register 'rb ra)
(set-register 'ra u)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-3-k]
(if (pair? ra)
(begin
(set-register 'ra 0)
(apply-k))
(begin
(set-register 'ra 1)
(apply-k))))
([list 'nock-4-k]
(begin
(set-register 'ra (+ 1 ra))
(apply-k)))
([list 'nock-5-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-5-k-2)
(push-k-data (nock-5-k-2 ra))
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-5-k-2 (var u)]
(if (eqv? u ra)
(begin
(set-register 'ra 0)
(apply-k))
(begin
(set-register 'ra 1)
(apply-k))))
([list 'nock-6-k (var subject) (var c) (var d) (var gates) (var err-k) (var trace)]
(if (= 0 ra)
(begin
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))
(if (= 1 ra)
(begin
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))
(begin
(set-register 'ra err-k)
(set-register 'rb (cons 2 trace))
(apply-err-k)))))
([list 'nock-7-k (var c) (var gates) (var err-k) (var trace)]
(begin
; ra already set
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-8-k (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(set-register 'ra (cons ra subject))
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-9-k-1 (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-9-k-2)
(push-k-data (nock-9-k-2 ra gates err-k trace))
; ra already set
(set-register 'rb b)
(set-register 'rc err-k)
(set-register 'rd trace)
(nock-tree-find)))
([list 'nock-9-k-2 (var u) (var gates) (var err-k) (var trace)]
(begin
(set-register 'rb ra)
(set-register 'ra u)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-10-k-1 (var subject) (var d) (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-10-k-2)
(push-k-data (nock-10-k-2 ra b err-k trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-10-k-2 (var u) (var b) (var err-k) (var trace)]
(begin
(set-register 'rc ra)
(set-register 'ra u)
(set-register 'rb b)
(set-register 'rd err-k)
(set-register 're trace)
(nock-tree-edit)))
([list 'nock-11-k (var subject) (var b) (var d) (var gates) (var err-k) (var trace)]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(begin
(set-register 're (cons (cons b ra) trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(nock-noun-cps))
(begin
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))))
([list 'nock-12-k-1 (var subject) (var path) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-12-k-2)
(push-k-data (nock-12-k-2 gates err-k trace ra))
(set-register 'ra subject)
(set-register 'rb path)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-12-k-2 (var gates) (var err-k) (var trace) (var u)]
(let*
[(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons u ra) (cdr (cdr gate)))))]
(begin
(push-k-control 'nock-12-k-3)
(push-k-data (nock-12-k-3 u ra outer-err-k outer-trace))
(set-register 'ra core)
(set-register 'rb (car core))
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))))
([list 'nock-12-k-3 (var u) (var v) (var outer-err-k) (var outer-trace)]
(if (equal? 0 ra)
; ~
(begin
(set-register 'ra outer-err-k)
(set-register 'rb (cons 1 (cdr v)))
(apply-err-k))
(if (equal? 0 (car ra))
(begin
(set-register 'ra outer-err-k)
(set-register 'rb (cons 2 (cons (cons (tas "hunk") (cons u v)) outer-trace)))
(apply-err-k))
(begin
(set-register 'ra (cdr (cdr ra)))
(apply-k)))))
([list 'nock-tree-edit-car-k (var tree)]
(begin
(set-register 'ra (cons ra (cdr tree)))
(apply-k)))
([list 'nock-tree-edit-cdr-k (var tree)]
(begin
(set-register 'ra (cons (car tree) ra))
(apply-k)))
([list 'nock-tree-edit-k (var subtree) (var tree)]
(begin
(set-register 'rb ra)
(set-register 'ra subtree)
(set-register 'rc tree)
(nock-tree-edit-reversed)))
([list 'nock-tree-find-k (var tree)]
(begin
(set-register 'rb ra)
(set-register 'ra tree)
(nock-tree-find-reversed)))
((var k^) #:when (procedure? k^) (k^ ra))))))
; ra - err continuation
; rb - err trace
(define (apply-err-k) (ra))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
; rb - err trace
(define (test-err-k)
(printf "Error: ~v" ra)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

639
fifth-pass/nock-l-imperative-cons.rkt Normal file
View File

@ -0,0 +1,639 @@
#lang racket
(require rackunit)
;; This pass makes cons, car, and cdr operations explicitly
;; imperative and places their results in registers
;;
(define stack '())
(define (push-k-data k)
(set! stack (cons k stack)))
(define control-stack '())
(define (push-k-control k)
(set! control-stack (cons k control-stack)))
(define ra 0)
(define rb 0)
(define rc 0)
(define rd 0)
(define re 0)
(define rf 0)
(define rg 0)
(define rh 0)
(define ri 0)
(define rj 0)
(define rk 0)
(define (set-register register x)
(match register
('ra (set! ra x))
('rb (set! rb x))
('rc (set! rc x))
('rd (set! rd x))
('re (set! re x))
('rf (set! rf x))
('rg (set! rg x))
('rh (set! rh x))
('ri (set! ri x))
('rj (set! rj x))
('rk (set! rk x))))
(define (cell! register x y)
(set-register register (cons x y)))
(define (car! register x)
(set-register register (car x)))
(define (cdr! register x)
(set-register register (cdr x)))
(define (cell?! register x)
(if (pair? x)
(set-register register 0)
(set-register register 1)))
(define (tru? x)
(= x 0))
; interface with non-CPS, non-registerized calling convention
(define (nock-noun subject formula gates err-k trace)
(begin
(push-k-control 'empty-k)
(push-k-data empty-k)
(set-register 'ra subject)
(set-register 'rb formula)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
; ra - subject
; rb - formula
; rc - gate stack
; rd - err continuation
; re - err trace
(define (nock-noun-cps)
(begin
(car! 'rf rb)
(cdr! 'rg rb)
(cell?! 'rh rf)
(cond
[(tru? rh)
(begin
(push-k-control 'nock-cons-k-1)
(push-k-data (nock-cons-k-1 ra rg rc rd re))
(car! 'rh rf)
(cdr! 'ri rf)
; ra already set
(cons! 'rb rh ri)
; rb already set
; rc already set
; rd already set
; re already set
(nock-noun-cps))]
[(= rf 0)
(begin
; b in rg
(set-register 'rb rg)
(set-register 'rc rd)
(set-register 'rd re)
(nock-tree-find))]
[(= rf 1)
(begin
; b in rg
(set-register 'ra rg)
(apply-k))]
[(= rf 2)
(begin
(car! 'rh rg)
(cdr! 'ri rg)
; b in rh
; c in ri
(push-k-control 'nock-2-k-1)
(push-k-data (nock-2-k-1 ra ri rc rd re))
(set-register 'rb rh)
(nock-noun-cps))]
[(= rf 3)
(begin
(push-k-control 'nock-3-k)
(push-k-data nock-3-k)
; b in rg
(set-register 'rb rg)
(nock-noun-cps))]
[(= rf 4)
(begin
(push-k-control 'nock-4-k)
(push-k-data nock-4-k)
; b in rg
(set-register 'rb rg)
(nock-noun-cps))]
[(= rf 5)
(begin
(car! 'rh rg)
(cdr! 'ri rg)
(push-k-control 'nock-5-k-1)
; b in rh
; c in ri
(push-k-data (nock-5-k-1 ra ri rc rd re))
(set-register 'rb rh)
(nock-noun-cps))]
[(= rf 6)
(begin
(car! 'rh rg)
(cdr! 'ri rg)
(car! 'rj ri)
(car! 'rk ri)
; b in rh
; c in rj
; d in rk
(push-k-control nock-6-k)
(push-k-data (nock-6-k ra rj rk rc rd re))
(set-register 'rb rh)
(nock-noun-cps))]
[(= rf 7)
(begin
(car! 'rh rg)
(cdr! 'ri rg)
; b in rh
; c in ri
(push-k-control 'nock-7-k)
(push-k-data (nock-7-k ri rc rd re))
(set-register 'rb ri))]
[(= rf 8)
(begin
(car! 'rh rg)
(cdr! 'ri rg)
; b in rh
; c in ri
(push-k-control 'nock-8-k)
(push-k-data (nock-8-k ra ri rc rd re))
(set-register 'rb b)
(nock-noun-cps))]
[(= rf 9)
(begin
(car! 'rh rg)
(cdr! 'ri rg)
; b in rh
; c in ri
(push-k-control 'nock-9-k-1)
(push-k-data (nock-9-k-1 rh rc rd re))
(set-register 'rb ri)
(nock-noun-cps))]
[(= rf 10)
(begin
(car! 'rh rg)
(cdr! 'ri rg)
(car! 'rj rh)
(cdr! 'rk rh)
; b in rj
; c in rk
; d in ri
(push-k-control 'nock-10-k-1)
(push-k-data (nock-10-k-1 ra ri rj rc rd re))
(set-register 'rb rk)
(nock-noun-cps))
[(= rf 11)
(begin
(car! 'rh rg)
(cell?! 'ri rh)
(if (tru? ri)
(begin
(cdr! 'ri rg)
(car! 'rj rh)
(cdr! 'rk rh)
; b in rj
; c in rk
; d in ri
(push-k-control 'nock-11-k-1)
(push-k-data (nock-11-k ra rj ri rc rd re))
(set-register 'rb rk)
(nock-noun-cps))
(begin
(cdr! 'ri rg)
; b in rh
; c in ri
(set-register 'rb c)
(nock-noun-cps))))]
[(= rf 12)
(begin
(car! 'rh rg)
(cdr! 'ri rh)
; ref in rh
; path in ri
(push-k-control 'nock-12-k-1)
(push-k-data ra ri rc rd re)
(set-register 'rb rh)
(nock-noun-cps))])))
; ra - address to reverse
(define (reverse-address)
(begin
; ra already set
(set-register 'rb 1)
(reverse-address-acc)))
; ra - address to reverse
; rb - accumulator for reversed address
(define (reverse-address-acc)
(if (= ra 1)
(begin
(set-register 'ra rb)
(apply-k))
(begin
(set-register 'rb (bitwise-ior (arithmetic-shift rb 1) (bitwise-and ra 1)))
(set-register 'ra (arithmetic-shift ra -1))
(reverse-address-acc))))
; ra - tree to find subtree of
; rb - reversed address to find
(define (nock-tree-find-reversed)
(if (= rb 1)
; ra already set
(apply-k)
(if (even? rb)
(begin
(set-register 'ra (car ra))
(set-register 'rb (arithmetic-shift rb -1))
(nock-tree-find-reversed))
(begin
(set-register 'ra (cdr ra))
(set-register 'rb (arithmetic-shift rb -1))
(nock-tree-find-reversed)))))
; ra - tree to find subtree of
; rb - address of subtree
; rc - err continuation
; rd - err trace
(define (nock-tree-find)
(if (= rb 0)
(begin
(set-register 'ra rc)
(set-register 'rb (cons 2 rd))
(apply-err-k))
(begin
(push-k-control 'nock-tree-find-k)
(push-k-data (nock-tree-find-k ra))
(set-register 'ra rb)
(reverse-address))))
; ra - subtree to place at address
; rb - reversed address
; rc - tree to edit
(define (nock-tree-edit-reversed)
(if (= rb 1)
; ra already set
(apply-k)
(if (even? rb)
(begin
(push-k-control 'nock-tree-edit-car-k)
(push-k-data (nock-tree-edit-car-k rc))
; ra already set
(set-register 'rb (arithmetic-shift rb -1))
(set-register 'rc (car rc))
(nock-tree-edit-reversed))
(begin
(push-k-control 'nock-tree-edit-cdr-k)
(push-k-data (nock-tree-edit-cdr-k rc))
; ra already set
(set-register 'rb (arithmetic-shift rb -1))
(set-register 'rc (cdr rc))
(nock-tree-edit-reversed)))))
; # operator in nock spec: tree editing
; ra - subtree to place at address
; rb - address
; rc - tree to edit
; rd - err continuation
; re - err trace
(define (nock-tree-edit)
(if (= rb 0)
(begin
(set-register 'ra rd)
(set-register 'rb (cons 2 re))
(apply-err-k))
(begin
(push-k-control 'nock-tree-edit-k)
(push-k-data (nock-tree-edit-k ra rc))
(set-register 'ra rb)
(reverse-address))))
(define empty-k '())
(define (nock-cons-k-1 subject d gates err-k trace) (list subject d gates err-k trace))
(define (nock-cons-k-2 u) (list u))
(define (nock-2-k-1 subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-2-k-2 u gates err-k trace) (list u gates err-k trace))
(define nock-3-k '())
(define nock-4-k '())
(define (nock-5-k-1 subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-5-k-2 u) (list u))
(define (nock-6-k subject c d gates err-k trace) (list subject c d gates err-k trace))
(define (nock-7-k c gates err-k trace) (list c gates err-k trace))
(define (nock-8-k subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-9-k-1 b gates err-k trace) (list b gates err-k trace))
(define (nock-9-k-2 u gates err-k trace) (list u gates err-k trace))
(define (nock-10-k-1 subject d b gates err-k trace) (list subject d b gates err-k trace))
(define (nock-10-k-2 u b err-k trace) (list u b err-k trace))
(define (nock-11-k subject b d gates err-k trace) (list subject b d gates err-k trace))
(define (nock-12-k-1 subject path gates err-k trace) (list subject path gates err-k trace))
(define (nock-12-k-2 gates err-k trace u) (list gates err-k trace u))
(define (nock-12-k-3 u v outer-err-k outer-trace) (list u v outer-err-k outer-trace))
(define (nock-tree-find-k tree) (list tree))
(define (nock-tree-edit-car-k tree) (list tree))
(define (nock-tree-edit-cdr-k tree) (list tree))
(define (nock-tree-edit-k subtree tree) (list subtree tree))
; apply the continuation from the top of the stack
; ra - result
(define (apply-k)
(let
[(data (car stack))
(k (car control-stack))]
(begin
(set! stack (cdr stack))
(set! control-stack (cdr control-stack))
(match (cons k data)
([list 'empty-k] ra)
([list 'nock-cons-k-1 (var subject) (var d) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-cons-k-2)
(push-k-data (nock-cons-k-2 ra))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-cons-k-2 (var u) (var k^)]
(begin
(set-register 'ra (cons u ra))
(apply-k)))
([list 'nock-2-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-2-k-2)
(push-k-data (nock-2-k-2 ra gates err-k trace))
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-2-k-2 (var u) (var gates) (var err-k) (var trace)]
(begin
(set-register 'rb ra)
(set-register 'ra u)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-3-k]
(if (pair? ra)
(begin
(set-register 'ra 0)
(apply-k))
(begin
(set-register 'ra 1)
(apply-k))))
([list 'nock-4-k]
(begin
(set-register 'ra (+ 1 ra))
(apply-k)))
([list 'nock-5-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-5-k-2)
(push-k-data (nock-5-k-2 ra))
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-5-k-2 (var u)]
(if (eqv? u ra)
(begin
(set-register 'ra 0)
(apply-k))
(begin
(set-register 'ra 1)
(apply-k))))
([list 'nock-6-k (var subject) (var c) (var d) (var gates) (var err-k) (var trace)]
(if (= 0 ra)
(begin
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))
(if (= 1 ra)
(begin
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))
(begin
(set-register 'ra err-k)
(set-register 'rb (cons 2 trace))
(apply-err-k)))))
([list 'nock-7-k (var c) (var gates) (var err-k) (var trace)]
(begin
; ra already set
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-8-k (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(set-register 'ra (cons ra subject))
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-9-k-1 (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-9-k-2)
(push-k-data (nock-9-k-2 ra gates err-k trace))
; ra already set
(set-register 'rb b)
(set-register 'rc err-k)
(set-register 'rd trace)
(nock-tree-find)))
([list 'nock-9-k-2 (var u) (var gates) (var err-k) (var trace)]
(begin
(set-register 'rb ra)
(set-register 'ra u)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-10-k-1 (var subject) (var d) (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-10-k-2)
(push-k-data (nock-10-k-2 ra b err-k trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-10-k-2 (var u) (var b) (var err-k) (var trace)]
(begin
(set-register 'rc ra)
(set-register 'ra u)
(set-register 'rb b)
(set-register 'rd err-k)
(set-register 're trace)
(nock-tree-edit)))
([list 'nock-11-k (var subject) (var b) (var d) (var gates) (var err-k) (var trace)]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(begin
(set-register 're (cons (cons b ra) trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(nock-noun-cps))
(begin
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))))
([list 'nock-12-k-1 (var subject) (var path) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-12-k-2)
(push-k-data (nock-12-k-2 gates err-k trace ra))
(set-register 'ra subject)
(set-register 'rb path)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-12-k-2 (var gates) (var err-k) (var trace) (var u)]
(let*
[(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons u ra) (cdr (cdr gate)))))]
(begin
(push-k-control 'nock-12-k-3)
(push-k-data (nock-12-k-3 u ra outer-err-k outer-trace))
(set-register 'ra core)
(set-register 'rb (car core))
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))))
([list 'nock-12-k-3 (var u) (var v) (var outer-err-k) (var outer-trace)]
(if (equal? 0 ra)
; ~
(begin
(set-register 'ra outer-err-k)
(set-register 'rb (cons 1 (cdr v)))
(apply-err-k))
(if (equal? 0 (car ra))
(begin
(set-register 'ra outer-err-k)
(set-register 'rb (cons 2 (cons (cons (tas "hunk") (cons u v)) outer-trace)))
(apply-err-k))
(begin
(set-register 'ra (cdr (cdr ra)))
(apply-k)))))
([list 'nock-tree-edit-car-k (var tree)]
(begin
(set-register 'ra (cons ra (cdr tree)))
(apply-k)))
([list 'nock-tree-edit-cdr-k (var tree)]
(begin
(set-register 'ra (cons (car tree) ra))
(apply-k)))
([list 'nock-tree-edit-k (var subtree) (var tree)]
(begin
(set-register 'rb ra)
(set-register 'ra subtree)
(set-register 'rc tree)
(nock-tree-edit-reversed)))
([list 'nock-tree-find-k (var tree)]
(begin
(set-register 'rb ra)
(set-register 'ra tree)
(nock-tree-find-reversed)))
((var k^) #:when (procedure? k^) (k^ ra))))))
; ra - err continuation
; rb - err trace
(define (apply-err-k) (ra))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
; rb - err trace
(define (test-err-k)
(printf "Error: ~v" ra)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic

4
nock-a.rkt
View File

@ -2,6 +2,10 @@
(require rackunit)
;; This is a naive, direct, structurally recursive interpretation of Nock according
;; to the nock specification, with cells represented as cons cells and atoms represented
;; as Racket natural numbers.
(define (nock-noun subject formula)
(match formula
([cons (cons (var b) (var c)) (var d)]

6
nock-b-scry.rkt
View File

@ -2,6 +2,12 @@
(require rackunit)
;; This interpreter adds to (a) handling for a stack of scry gates
;;
;; Thus, it implements "nock 12" from the ++mink metacircular Nock interpreter
;; This is necessary so that the system nock interpreter can be used to jet
;; ++mink, resulting in virtualized Nock computations.
(define (nock-noun subject formula gates)
(let*
[(recur-on-noun (lambda (subject formula)

5
nock-c-exceptions.rkt
View File

@ -2,6 +2,11 @@
(require rackunit)
;; This interpreter builds on (b) by adding an explicit exception-handling mechanism
;; in the form of an error continuation and a trace.
;;
;; Traces are updated by specific static hints for nock 11 paired with specific dynamic hints.
(define (nock-noun subject formula gates err-k trace)
(let*
[(recur-on-noun (lambda (subject formula)

2
nock-d-inline.rkt
View File

@ -2,6 +2,8 @@
(require rackunit)
;; This pass inlines top-level recursion helpers resulting in direct calls to `nock-noun`
(define (nock-noun subject formula gates err-k trace)
(match formula
([cons (cons (var b) (var c)) (var d)]

3
nock-e-optimize-edit.rkt
View File

@ -2,6 +2,9 @@
(require rackunit)
;; This pass optimizes the nock-tree-edit (and nock-tree-find) functions by reversing the atom
;; passed as an address
(define (nock-noun subject formula gates err-k trace)
(match formula
([cons (cons (var b) (var c)) (var d)]

5
nock-f-cps.rkt
View File

@ -2,6 +2,11 @@
(require rackunit)
;; This interpreter is a translation of the interpreter in (e) into continuation-passing style (CPS).
;;
;; Rather than return a result, functions take a function (called a continuation) to which to pass
;; their result, and invoke it. This creates a linear sequence of invocations rather than nested expressions.
(define (nock-noun subject formula gates err-k trace)
(nock-noun-cps subject formula gates err-k trace empty-k))

3
nock-g-explicit-apply.rkt
View File

@ -2,6 +2,9 @@
(require rackunit)
;; This interpreter adds an explicit function for applying continuations,
;; a necessary pre-requisite to closure conversion
(define (nock-noun subject formula gates err-k trace)
(nock-noun-cps subject formula gates err-k trace empty-k))

4
nock-h-closure-convert.rkt
View File

@ -2,6 +2,10 @@
(require rackunit)
;; This interpreter removes all nested lambdas by converting them
;; into a tagged union, which is matched by the continuation-application
;; function to invoke the body of the lambda.
(define (nock-noun subject formula gates err-k trace)
(nock-noun-cps subject formula gates err-k trace empty-k))

9
nock-i-k-stack.rkt
View File

@ -2,6 +2,15 @@
(require rackunit)
;; This interpreter converts the implicit stack of continuations from (j)
;; (represented by every continuation closure other than empty-k receiving
;; the current continuation as its last argument) into an explicit stack.
;;
;; It removes the continuation variable from all continuation closures
;; and adds a `push-k` operation to push a continuation closure onto the stack.
;;
;; The apply-k function now functions explicitly as a stack-popping operation.
(define stack '())
(define (push-k k)
(set! stack (cons k stack)))

2
nock-j-registerize.rkt
View File

@ -426,11 +426,11 @@
([list 'nock-11-k (var subject) (var b) (var d) (var gates) (var err-k) (var trace)]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(begin
(set-register 're (cons (cons b ra) trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're (cons (cons b ra) trace))
(nock-noun-cps))
(begin
(set-register 'ra subject)

601
nock-k-separate-control-stack.rkt Normal file
View File

@ -0,0 +1,601 @@
#lang racket
(require rackunit)
;; This pass builds on the mutable state (the continuation stack) introduced in (i)
;; and adds mutable registers, which are updated by the `set-register` function.
;;
;; Procedures no longer take language-native arguments, but have an explicit convention
;; for the globally-defined registers in which they expect their arguments.
(define stack '())
(define (push-k-data k)
(set! stack (cons k stack)))
(define control-stack '())
(define (push-k-control k)
(set! control-stack (cons k control-stack)))
(define ra 0)
(define rb 0)
(define rc 0)
(define rd 0)
(define re 0)
(define (set-register register x)
(match register
('ra (set! ra x))
('rb (set! rb x))
('rc (set! rc x))
('rd (set! rd x))
('re (set! re x))))
; interface with non-CPS, non-registerized calling convention
(define (nock-noun subject formula gates err-k trace)
(begin
(push-k-control 'empty-k)
(push-k-data empty-k)
(set-register 'ra subject)
(set-register 'rb formula)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
; ra - subject
; rb - formula
; rc - gate stack
; rd - err continuation
; re - err trace
(define (nock-noun-cps)
(match rb
([cons (cons (var b) (var c)) (var d)]
(begin
(push-k-control 'nock-cons-k-1)
(push-k-data (nock-cons-k-1 ra d rc rd re))
; ra already set
(set-register 'rb (cons b c))
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 0 (var b)]
(begin
; ra already set
(set-register 'rb b)
(set-register 'rc rd)
(set-register 'rd re)
(nock-tree-find)))
([cons 1 (var b)]
(begin
(set-register 'ra b)
(apply-k)))
([cons 2 (cons (var b) (var c))]
(begin
(push-k-control 'nock-2-k-1)
(push-k-data (nock-2-k-1 ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 3 (var b)]
(begin
(push-k-control 'nock-3-k)
(push-k-data nock-3-k)
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 4 (var b)]
(begin
(push-k-control 'nock-4-k)
(push-k-data nock-4-k)
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 5 (cons (var b) (var c))]
(begin
(push-k-control 'nock-5-k-1)
(push-k-data (nock-5-k-1 ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 6 (cons (var b) (cons (var c) (var d)))]
(begin
(push-k-control 'nock-6-k)
(push-k-data (nock-6-k ra c d rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 7 (cons (var b) (var c))]
(begin
(push-k-control 'nock-7-k)
(push-k-data (nock-7-k c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 8 (cons (var b) (var c))]
(begin
(push-k-control 'nock-8-k)
(push-k-data (nock-8-k ra c rc rd re))
; ra already set
(set-register 'rb b)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 9 (cons (var b) (var c))]
(begin
(push-k-control 'nock-9-k-1)
(push-k-data (nock-9-k-1 b rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 10 (cons (cons (var b) (var c)) (var d))]
(begin
(push-k-control 'nock-10-k-1)
(push-k-data (nock-10-k-1 ra d b rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 11 (cons (cons (var b) (var c)) (var d))]
(begin
(push-k-control 'nock-11-k)
(push-k-data (nock-11-k ra b d rc rd re))
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 11 (cons (var b) (var c))]
(begin
; ra already set
(set-register 'rb c)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))
([cons 12 (cons (var ref) (var path))]
(begin
(push-k-control 'nock-12-k-1)
(push-k-data (nock-12-k-1 ra path rc rd re))
; ra already set
(set-register 'rb ref)
; rc already set
; rd already set
; re already set
(nock-noun-cps)))))
; ra - address to reverse
(define (reverse-address)
(begin
; ra already set
(set-register 'rb 1)
(reverse-address-acc)))
; ra - address to reverse
; rb - accumulator for reversed address
(define (reverse-address-acc)
(if (= ra 1)
(begin
(set-register 'ra rb)
(apply-k))
(begin
(set-register 'rb (bitwise-ior (arithmetic-shift rb 1) (bitwise-and ra 1)))
(set-register 'ra (arithmetic-shift ra -1))
(reverse-address-acc))))
; ra - tree to find subtree of
; rb - reversed address to find
(define (nock-tree-find-reversed)
(if (= rb 1)
; ra already set
(apply-k)
(if (even? rb)
(begin
(set-register 'ra (car ra))
(set-register 'rb (arithmetic-shift rb -1))
(nock-tree-find-reversed))
(begin
(set-register 'ra (cdr ra))
(set-register 'rb (arithmetic-shift rb -1))
(nock-tree-find-reversed)))))
; ra - tree to find subtree of
; rb - address of subtree
; rc - err continuation
; rd - err trace
(define (nock-tree-find)
(if (= rb 0)
(begin
(set-register 'ra rc)
(set-register 'rb (cons 2 rd))
(apply-err-k))
(begin
(push-k-control 'nock-tree-find-k)
(push-k-data (nock-tree-find-k ra))
(set-register 'ra rb)
(reverse-address))))
; ra - subtree to place at address
; rb - reversed address
; rc - tree to edit
(define (nock-tree-edit-reversed)
(if (= rb 1)
; ra already set
(apply-k)
(if (even? rb)
(begin
(push-k-control 'nock-tree-edit-car-k)
(push-k-data (nock-tree-edit-car-k rc))
; ra already set
(set-register 'rb (arithmetic-shift rb -1))
(set-register 'rc (car rc))
(nock-tree-edit-reversed))
(begin
(push-k-control 'nock-tree-edit-cdr-k)
(push-k-data (nock-tree-edit-cdr-k rc))
; ra already set
(set-register 'rb (arithmetic-shift rb -1))
(set-register 'rc (cdr rc))
(nock-tree-edit-reversed)))))
; # operator in nock spec: tree editing
; ra - subtree to place at address
; rb - address
; rc - tree to edit
; rd - err continuation
; re - err trace
(define (nock-tree-edit)
(if (= rb 0)
(begin
(set-register 'ra rd)
(set-register 'rb (cons 2 re))
(apply-err-k))
(begin
(push-k-control 'nock-tree-edit-k)
(push-k-data (nock-tree-edit-k ra rc))
(set-register 'ra rb)
(reverse-address))))
(define empty-k '())
(define (nock-cons-k-1 subject d gates err-k trace) (list subject d gates err-k trace))
(define (nock-cons-k-2 u) (list u))
(define (nock-2-k-1 subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-2-k-2 u gates err-k trace) (list u gates err-k trace))
(define nock-3-k '())
(define nock-4-k '())
(define (nock-5-k-1 subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-5-k-2 u) (list u))
(define (nock-6-k subject c d gates err-k trace) (list subject c d gates err-k trace))
(define (nock-7-k c gates err-k trace) (list c gates err-k trace))
(define (nock-8-k subject c gates err-k trace) (list subject c gates err-k trace))
(define (nock-9-k-1 b gates err-k trace) (list b gates err-k trace))
(define (nock-9-k-2 u gates err-k trace) (list u gates err-k trace))
(define (nock-10-k-1 subject d b gates err-k trace) (list subject d b gates err-k trace))
(define (nock-10-k-2 u b err-k trace) (list u b err-k trace))
(define (nock-11-k subject b d gates err-k trace) (list subject b d gates err-k trace))
(define (nock-12-k-1 subject path gates err-k trace) (list subject path gates err-k trace))
(define (nock-12-k-2 gates err-k trace u) (list gates err-k trace u))
(define (nock-12-k-3 u v outer-err-k outer-trace) (list u v outer-err-k outer-trace))
(define (nock-tree-find-k tree) (list tree))
(define (nock-tree-edit-car-k tree) (list tree))
(define (nock-tree-edit-cdr-k tree) (list tree))
(define (nock-tree-edit-k subtree tree) (list subtree tree))
; apply the continuation from the top of the stack
; ra - result
(define (apply-k)
(let
[(data (car stack))
(k (car control-stack))]
(begin
(set! stack (cdr stack))
(set! control-stack (cdr control-stack))
(match (cons k data)
([list 'empty-k] ra)
([list 'nock-cons-k-1 (var subject) (var d) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-cons-k-2)
(push-k-data (nock-cons-k-2 ra))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-cons-k-2 (var u) (var k^)]
(begin
(set-register 'ra (cons u ra))
(apply-k)))
([list 'nock-2-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-2-k-2)
(push-k-data (nock-2-k-2 ra gates err-k trace))
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-2-k-2 (var u) (var gates) (var err-k) (var trace)]
(begin
(set-register 'rb ra)
(set-register 'ra u)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-3-k]
(if (pair? ra)
(begin
(set-register 'ra 0)
(apply-k))
(begin
(set-register 'ra 1)
(apply-k))))
([list 'nock-4-k]
(begin
(set-register 'ra (+ 1 ra))
(apply-k)))
([list 'nock-5-k-1 (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-5-k-2)
(push-k-data (nock-5-k-2 ra))
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-5-k-2 (var u)]
(if (eqv? u ra)
(begin
(set-register 'ra 0)
(apply-k))
(begin
(set-register 'ra 1)
(apply-k))))
([list 'nock-6-k (var subject) (var c) (var d) (var gates) (var err-k) (var trace)]
(if (= 0 ra)
(begin
(set-register 'ra subject)
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))
(if (= 1 ra)
(begin
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))
(begin
(set-register 'ra err-k)
(set-register 'rb (cons 2 trace))
(apply-err-k)))))
([list 'nock-7-k (var c) (var gates) (var err-k) (var trace)]
(begin
; ra already set
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-8-k (var subject) (var c) (var gates) (var err-k) (var trace)]
(begin
(set-register 'ra (cons ra subject))
(set-register 'rb c)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-9-k-1 (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-9-k-2)
(push-k-data (nock-9-k-2 ra gates err-k trace))
; ra already set
(set-register 'rb b)
(set-register 'rc err-k)
(set-register 'rd trace)
(nock-tree-find)))
([list 'nock-9-k-2 (var u) (var gates) (var err-k) (var trace)]
(begin
(set-register 'rb ra)
(set-register 'ra u)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-10-k-1 (var subject) (var d) (var b) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-10-k-2)
(push-k-data (nock-10-k-2 ra b err-k trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-10-k-2 (var u) (var b) (var err-k) (var trace)]
(begin
(set-register 'rc ra)
(set-register 'ra u)
(set-register 'rb b)
(set-register 'rd err-k)
(set-register 're trace)
(nock-tree-edit)))
([list 'nock-11-k (var subject) (var b) (var d) (var gates) (var err-k) (var trace)]
(if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot")))
(begin
(set-register 're (cons (cons b ra) trace))
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(nock-noun-cps))
(begin
(set-register 'ra subject)
(set-register 'rb d)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))))
([list 'nock-12-k-1 (var subject) (var path) (var gates) (var err-k) (var trace)]
(begin
(push-k-control 'nock-12-k-2)
(push-k-data (nock-12-k-2 gates err-k trace ra))
(set-register 'ra subject)
(set-register 'rb path)
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps)))
([list 'nock-12-k-2 (var gates) (var err-k) (var trace) (var u)]
(let*
[(gate (car (car gates)))
(outer-err-k err-k)
(err-k (car (cdr (car gates))))
(outer-trace trace)
(trace (cdr (cdr (car gates))))
(gates (cdr gates))
(core (cons (car gate) (cons (cons u ra) (cdr (cdr gate)))))]
(begin
(push-k-control 'nock-12-k-3)
(push-k-data (nock-12-k-3 u ra outer-err-k outer-trace))
(set-register 'ra core)
(set-register 'rb (car core))
(set-register 'rc gates)
(set-register 'rd err-k)
(set-register 're trace)
(nock-noun-cps))))
([list 'nock-12-k-3 (var u) (var v) (var outer-err-k) (var outer-trace)]
(if (equal? 0 ra)
; ~
(begin
(set-register 'ra outer-err-k)
(set-register 'rb (cons 1 (cdr v)))
(apply-err-k))
(if (equal? 0 (car ra))
(begin
(set-register 'ra outer-err-k)
(set-register 'rb (cons 2 (cons (cons (tas "hunk") (cons u v)) outer-trace)))
(apply-err-k))
(begin
(set-register 'ra (cdr (cdr ra)))
(apply-k)))))
([list 'nock-tree-edit-car-k (var tree)]
(begin
(set-register 'ra (cons ra (cdr tree)))
(apply-k)))
([list 'nock-tree-edit-cdr-k (var tree)]
(begin
(set-register 'ra (cons (car tree) ra))
(apply-k)))
([list 'nock-tree-edit-k (var subtree) (var tree)]
(begin
(set-register 'rb ra)
(set-register 'ra subtree)
(set-register 'rc tree)
(nock-tree-edit-reversed)))
([list 'nock-tree-find-k (var tree)]
(begin
(set-register 'rb ra)
(set-register 'ra tree)
(nock-tree-find-reversed)))
((var k^) #:when (procedure? k^) (k^ ra))))))
; ra - err continuation
; rb - err trace
(define (apply-err-k) (ra))
;; macro for %tas literals:
;; converts input string into a numeric literal of that string represented as a %tas, i.e. an
;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB)
(define-syntax (tas str)
(quasisyntax
(unsyntax
(foldr
(lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8)))
0
(string->list (car (cdr (syntax->datum str))))))))
(define nock-here 1)
(define (nock-car address) (* address 2))
(define (nock-cdr address) (+ 1 (* address 2)))
(define (get-0 x) (cons 0 x))
(define (literal-1 x) (cons 1 x))
(define (eval-2 x y) (cons 2 (cons x y)))
(define (cell?-3 x) (cons 3 x))
(define (inc-4 x) (cons 4 x))
(define (=-5 x y) (cons 5 (cons x y)))
(define (if-6 x y z) (cons 6 (cons x (cons y z))))
(define (compose-7 x y) (cons 7 (cons x y)))
(define (declare-8 x y) (cons 8 (cons x y)))
(define (call-9 x y) (cons 9 (cons x y)))
(define (update-10 x y z) (cons 10 (cons (cons x y) z)))
(define (hint-11 x y) (cons 11 (cons x y)))
(define lootru 0)
(define loofal 1)
(define test-tree (cons (cons 4 5) 3))
(define decrement-4-core
(cons
(if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))))
(get-0 (nock-cdr (nock-cdr nock-here)))
(call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here))))
(cons 4 0)))
(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '()))
; rb - err trace
(define (test-err-k)
(printf "Error: ~v" ra)
(error 'nock-err))
(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1")
(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2")
(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3")
(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4")
(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5")
(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal")
(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval")
(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true")
(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false")
(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true")
(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false")
(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru")
(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false")
(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose")
(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call")
(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update")
(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call")
; test 11 static and dynamic