diff --git a/fifth-pass/nock-a.rkt b/fifth-pass/nock-a.rkt new file mode 100644 index 0000000..5498345 --- /dev/null +++ b/fifth-pass/nock-a.rkt @@ -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 diff --git a/fifth-pass/nock-b-scry.rkt b/fifth-pass/nock-b-scry.rkt new file mode 100644 index 0000000..9ff73ea --- /dev/null +++ b/fifth-pass/nock-b-scry.rkt @@ -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 diff --git a/fifth-pass/nock-c-exceptions.rkt b/fifth-pass/nock-c-exceptions.rkt new file mode 100644 index 0000000..9ab14bb --- /dev/null +++ b/fifth-pass/nock-c-exceptions.rkt @@ -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 diff --git a/fifth-pass/nock-d-inline.rkt b/fifth-pass/nock-d-inline.rkt new file mode 100644 index 0000000..73302a0 --- /dev/null +++ b/fifth-pass/nock-d-inline.rkt @@ -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 diff --git a/fifth-pass/nock-e-optimize-edit.rkt b/fifth-pass/nock-e-optimize-edit.rkt new file mode 100644 index 0000000..61ce6a8 --- /dev/null +++ b/fifth-pass/nock-e-optimize-edit.rkt @@ -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 diff --git a/fifth-pass/nock-f-cps.rkt b/fifth-pass/nock-f-cps.rkt new file mode 100644 index 0000000..9699ab3 --- /dev/null +++ b/fifth-pass/nock-f-cps.rkt @@ -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 diff --git a/fifth-pass/nock-g-explicit-apply.rkt b/fifth-pass/nock-g-explicit-apply.rkt new file mode 100644 index 0000000..c183db7 --- /dev/null +++ b/fifth-pass/nock-g-explicit-apply.rkt @@ -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 diff --git a/fifth-pass/nock-h-closure-convert.rkt b/fifth-pass/nock-h-closure-convert.rkt new file mode 100644 index 0000000..a3c6064 --- /dev/null +++ b/fifth-pass/nock-h-closure-convert.rkt @@ -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 diff --git a/fifth-pass/nock-i-k-stack.rkt b/fifth-pass/nock-i-k-stack.rkt new file mode 100644 index 0000000..dd68ce2 --- /dev/null +++ b/fifth-pass/nock-i-k-stack.rkt @@ -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 diff --git a/fifth-pass/nock-j-registerize.rkt b/fifth-pass/nock-j-registerize.rkt new file mode 100644 index 0000000..4e4486a --- /dev/null +++ b/fifth-pass/nock-j-registerize.rkt @@ -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 diff --git a/fifth-pass/nock-k-separate-control-stack.rkt b/fifth-pass/nock-k-separate-control-stack.rkt new file mode 100644 index 0000000..f6491c5 --- /dev/null +++ b/fifth-pass/nock-k-separate-control-stack.rkt @@ -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 diff --git a/fifth-pass/nock-l-imperative-cons.rkt b/fifth-pass/nock-l-imperative-cons.rkt new file mode 100644 index 0000000..d3bdd1a --- /dev/null +++ b/fifth-pass/nock-l-imperative-cons.rkt @@ -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 diff --git a/nock-a.rkt b/nock-a.rkt index 6e5e622..5498345 100644 --- a/nock-a.rkt +++ b/nock-a.rkt @@ -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)] diff --git a/nock-b-scry.rkt b/nock-b-scry.rkt index b17448c..9ff73ea 100644 --- a/nock-b-scry.rkt +++ b/nock-b-scry.rkt @@ -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) diff --git a/nock-c-exceptions.rkt b/nock-c-exceptions.rkt index 133be70..9ab14bb 100644 --- a/nock-c-exceptions.rkt +++ b/nock-c-exceptions.rkt @@ -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) diff --git a/nock-d-inline.rkt b/nock-d-inline.rkt index 01838f8..73302a0 100644 --- a/nock-d-inline.rkt +++ b/nock-d-inline.rkt @@ -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)] diff --git a/nock-e-optimize-edit.rkt b/nock-e-optimize-edit.rkt index 0c6a89f..61ce6a8 100644 --- a/nock-e-optimize-edit.rkt +++ b/nock-e-optimize-edit.rkt @@ -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)] diff --git a/nock-f-cps.rkt b/nock-f-cps.rkt index f1e9d69..9699ab3 100644 --- a/nock-f-cps.rkt +++ b/nock-f-cps.rkt @@ -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)) diff --git a/nock-g-explicit-apply.rkt b/nock-g-explicit-apply.rkt index 7dda9f9..c183db7 100644 --- a/nock-g-explicit-apply.rkt +++ b/nock-g-explicit-apply.rkt @@ -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)) diff --git a/nock-h-closure-convert.rkt b/nock-h-closure-convert.rkt index 80ed338..a3c6064 100644 --- a/nock-h-closure-convert.rkt +++ b/nock-h-closure-convert.rkt @@ -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)) diff --git a/nock-i-k-stack.rkt b/nock-i-k-stack.rkt index e451db4..dd68ce2 100644 --- a/nock-i-k-stack.rkt +++ b/nock-i-k-stack.rkt @@ -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))) diff --git a/nock-j-registerize.rkt b/nock-j-registerize.rkt index e77b9f1..4e4486a 100644 --- a/nock-j-registerize.rkt +++ b/nock-j-registerize.rkt @@ -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) diff --git a/nock-k-separate-control-stack.rkt b/nock-k-separate-control-stack.rkt new file mode 100644 index 0000000..f6491c5 --- /dev/null +++ b/nock-k-separate-control-stack.rkt @@ -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