├── test-check.scm ├── README.md ├── base-tests.scm ├── matcher.scm ├── mk-tests.scm ├── mk.scm ├── matcher-tests.scm ├── pink-tests.scm ├── pink.scm └── base.scm /test-check.scm: -------------------------------------------------------------------------------- 1 | (define-syntax test 2 | (syntax-rules () 3 | ((_ title tested-expression expected-result) 4 | (begin 5 | (printf "Testing ~s\n" title) 6 | (let* ((expected expected-result) 7 | (produced tested-expression)) 8 | (or (equal? expected produced) 9 | (printf "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 10 | 'tested-expression expected produced))))))) 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pink in Scheme (Collapsing Towers of Interpreters) 2 | 3 | ## Code 4 | * __[`base.scm`](base.scm)__ defines the multi-level core language λ↑↓ as a definitional interpreter in Scheme. 5 | * __[`pink.scm`](pink.scm)__ defines the meta-circular stage-parametric interpreter for Pink on top of the base. 6 | * __[`matcher.scm`](matcher.scm)__ defines a matcher as an example on top of Pink. 7 | * __[`mk.scm`](mk.scm)__ defines a µKanren as an example on top of Pink. 8 | 9 | ## Run 10 | Each code file `.scm` above has a companion `-tests.scm`, which can be run with [Chez Scheme](https://cisco.github.io/ChezScheme/). 11 | For example, `chez pink-tests.scm` runs all the Pink-related tests. 12 | 13 | ## See Also 14 | 15 | * [Pink in Scala](http://popl18.namin.net) 16 | -------------------------------------------------------------------------------- /base-tests.scm: -------------------------------------------------------------------------------- 1 | (load "base.scm") 2 | (load "test-check.scm") 3 | 4 | (test "fac-4" 5 | (run (lambda () (evalms '() `((lambda (if (var 1) (* (var 1) ((var 0) (- (var 1) 1))) 1)) 4)))) 6 | 24) 7 | 8 | (test "number?-1" 9 | (run (lambda () (evalms '() '(number? 1)))) 10 | 1) 11 | 12 | (test "eq?-+" 13 | (run (lambda () (evalms '() '(eq? + (car (cons + 2)))))) 14 | 1 15 | ) 16 | 17 | (test "reifyc-1" 18 | (reifyc (lambda () (evalms '() `(if (lift 0) (+ (lift 1) (lift 2)) (lift 0))))) 19 | '(let (if 0 (let (+ 1 2) (var 0)) 0) (var 0)) 20 | ) 21 | 22 | (test "reifyc-fac" 23 | (reifyc (lambda () (evalms '() `(lift (lambda (if (var 1) (* (var 1) ((var 0) (- (var 1) (lift 1)))) (lift 1))))))) 24 | base-fac-anf 25 | ) 26 | 27 | (test "log" 28 | (run (lambda () (evalms '() '(log 1 1)))) 29 | 1 30 | ) 31 | 32 | (test "log-lift" 33 | (let ((c (reifyc (lambda () (evalms '() '(log (lift 1) 1)))))) 34 | (run (lambda () (evalms '() c)))) 35 | 1 36 | ) 37 | -------------------------------------------------------------------------------- /matcher.scm: -------------------------------------------------------------------------------- 1 | (define matcher-src 2 | '(let star_loop (lambda star_loop m (lambda _ c (maybe-lift (lambda inner_loop s 3 | (if (eq? (maybe-lift 'yes) (m s)) (maybe-lift 'yes) 4 | (if (eq? (maybe-lift 'done) (car s)) (maybe-lift 'no) 5 | (if (eq? '_ c) (inner_loop (cdr s)) 6 | (if (eq? (maybe-lift c) (car s)) (inner_loop (cdr s)) (maybe-lift 'no))))))))) 7 | (let match_here (lambda match_here r (lambda _ s (if (eq? 'done (car r)) (maybe-lift 'yes) 8 | (let m (lambda _ s 9 | (if (eq? '_ (car r)) (if (eq? (maybe-lift 'done) (car s)) (maybe-lift 'no) ((match_here (cdr r)) (cdr s))) 10 | (if (eq? (maybe-lift 'done) (car s)) (maybe-lift 'no) 11 | (if (eq? (maybe-lift (car r)) (car s)) ((match_here (cdr r)) (cdr s)) (maybe-lift 'no))))) 12 | (if (eq? 'done (car (cdr r))) (m s) 13 | (if (eq? '* (car (cdr r))) (((star_loop (match_here (cdr (cdr r)))) (car r)) s) (m s))))))) 14 | (let match (lambda match r 15 | (if (eq? 'done (car r)) (maybe-lift (lambda _ s (maybe-lift 'yes))) (maybe-lift (match_here r)))) 16 | match))) 17 | ) 18 | -------------------------------------------------------------------------------- /mk-tests.scm: -------------------------------------------------------------------------------- 1 | (load "base.scm") 2 | (load "pink.scm") 3 | (load "mk.scm") 4 | (load "test-check.scm") 5 | 6 | (test "mk-1" 7 | (evalms (list (mk '(let p ((call/fresh (lambda _ q ((== q) 5))) empty-state) (car p)))) `((,pink-eval-exp1 (var 0)) nil-env)) 8 | '((((var . 0) . 5)) . 1) 9 | ) 10 | 11 | (test "mk-2" 12 | (evalms (list (mk '(let p ((call/fresh (lambda _ q ((== q) 5))) empty-state) (cdr p)))) `((,pink-eval-exp1 (var 0)) nil-env)) 13 | '() 14 | ) 15 | 16 | 17 | (define a-and-b 18 | '((conj 19 | (call/fresh (lambda _ a ((== a) 7)))) 20 | (call/fresh 21 | (lambda _ b 22 | ((disj 23 | ((== b) 5)) 24 | ((== b) 6))))) 25 | ) 26 | 27 | (test "mk-3" 28 | (evalms (list (mk `(let p (,a-and-b empty-state) (car p)))) `((,pink-eval-exp1 (var 0)) nil-env)) 29 | '((((var . 1) . 5) ((var . 0) . 7)) . 2) 30 | ) 31 | 32 | (test "mk-3" 33 | (evalms (list (mk `(let p (,a-and-b empty-state) (car (cdr p))))) `((,pink-eval-exp1 (var 0)) nil-env)) 34 | '((((var . 1) . 6) ((var . 0) . 7)) . 2) 35 | ) 36 | 37 | (test "mk-4" 38 | (evalms (list (mk `(let p (,a-and-b empty-state) (cdr (cdr p))))) `((,pink-eval-exp1 (var 0)) nil-env)) 39 | '() 40 | ) 41 | 42 | (test "mk-compiled" 43 | (let ((p (evalms (list (mk `(clambda _ _ (,a-and-b empty-state)))) `((,pink-eval-exp1 (var 0)) nil-env)))) (evalms (list p) '((var 0) 0))) 44 | (let ((p (evalms (list (mk `(lambda _ _ (,a-and-b empty-state)))) `((,pink-eval-exp1 (var 0)) nil-env)))) (evalms (list p) '((var 0) 0))) 45 | ) 46 | -------------------------------------------------------------------------------- /mk.scm: -------------------------------------------------------------------------------- 1 | ;; from https://github.com/jasonhemann/microKanren/blob/master/microKanren.scm 2 | ;; see also http://webyrd.net/scheme-2013/papers/HemannMuKanren2013.pdf 3 | 4 | (define mk (lambda (program) 5 | `(let = (lambda _ a (lambda _ b (if (- a b) 0 1))) 6 | (let assp (lambda assp p (lambda _ s (if (pair? s) (if (p (car (car s))) (car s) ((assp p) (cdr s))) s))) 7 | (let var (lambda _ c (cons 'var c)) 8 | (let var? (lambda _ x (if (pair? x) (if (symbol? (car x)) (eq? 'var (car x)) 0) 0)) 9 | (let var=? (lambda _ x1 (lambda _ x2 ((= (cdr x1)) (cdr x2)))) 10 | (let walk (lambda walk u (lambda _ s 11 | (let pr (if (var? u) ((assp (var=? u)) s) '()) 12 | (if (null? pr) u ((walk (cdr pr)) s))))) 13 | (let ext-s (lambda _ x (lambda _ v (lambda _ s (cons (cons x v) s)))) 14 | (let mzero '() 15 | (let unit (lambda _ s/c (cons s/c mzero)) 16 | (let unify (lambda unify u (lambda _ v (lambda _ s 17 | (let u ((walk u) s) 18 | (let v ((walk v) s) 19 | (if (if (var? u) (if (var? v) ((var=? u) v) 0) 0) s 20 | (if (var? u) (((ext-s u) v) s) 21 | (if (var? v) (((ext-s v) u) s) 22 | (if (if (pair? u) (pair? v) 0) 23 | (let s (((unify (car u)) (car v)) s) 24 | (if (pair? s) (((unify (cdr u)) (cdr v)) s) 0)) 25 | (if (eq? u v) s '())))))))))) 26 | (let == (lambda _ u (lambda _ v (lambda _ s/c 27 | (let s (((unify u) v) (car s/c)) 28 | (if (pair? s) (unit (cons s (cdr s/c))) mzero))))) 29 | (let call/fresh (lambda _ f (lambda _ s/c 30 | (let c (cdr s/c) 31 | ((f (var c)) (cons (car s/c) (+ c 1)))))) 32 | (let mplus (lambda mplus $1 (lambda _ $2 33 | (if (null? $1) $2 34 | (if (pair? $1) (cons (car $1) ((mplus (cdr $1)) $2)) 35 | ;; (procedure? $1) 36 | (lambda _ _ ((mplus $2) ($1 0))))))) 37 | (let bind (lambda bind $ (lambda _ g 38 | (if (null? $) mzero 39 | (if (pair? $) ((mplus (g (car $))) ((bind (cdr $)) g)) 40 | ;; (procedure? $) 41 | (lambda _ _ ((bind ($ 0)) g)))))) 42 | (let disj (lambda _ g1 (lambda _ g2 (lambda _ s/c ((mplus (g1 s/c)) (g2 s/c))))) 43 | (let conj (lambda _ g1 (lambda _ g2 (lambda _ s/c ((bind (g1 s/c)) g2)))) 44 | (let empty-state (cons '() 0) 45 | ,program 46 | ))))))))))))))))) 47 | )) 48 | -------------------------------------------------------------------------------- /matcher-tests.scm: -------------------------------------------------------------------------------- 1 | (load "base.scm") 2 | (load "pink.scm") 3 | (load "matcher.scm") 4 | (load "test-check.scm") 5 | 6 | (test "matcher-1" 7 | (evalms (list `(let maybe-lift (lambda _ e e) ,matcher-src) 8 | `(_ * a _ * done) `(b a done)) 9 | `((((,pink-eval-exp3 (var 0)) nil-env) (var 1)) (var 2))) 10 | 'yes 11 | ) 12 | 13 | (test "matcher-2" 14 | (evalms (list `(let maybe-lift (lambda _ e e) ,matcher-src) 15 | `(_ * a _ * done) `(b b done)) 16 | `((((,pink-eval-exp3 (var 0)) nil-env) (var 1)) (var 2))) 17 | 'no 18 | ) 19 | 20 | (test "matcher-c-1" 21 | (let ((c (reifyc (lambda () (evalms (list `(let maybe-lift (lambda _ e (lift e)) ,matcher-src) 22 | `(_ * a _ * done)) 23 | `(((,pink-eval-exp2 (var 0)) nil-env) (var 1))))))) 24 | (run (lambda () (let ((v (evalms '() c))) 25 | (evalms (list `(b a done) v) `((var 1) (var 0))))))) 26 | 'yes 27 | ) 28 | 29 | (test "matcher-c-2" 30 | (let ((c (reifyc (lambda () (evalms (list `(let maybe-lift (lambda _ e (lift e)) ,matcher-src) 31 | `(_ * a _ * done)) 32 | `(((,pink-eval-exp2 (var 0)) nil-env) (var 1))))))) 33 | (run (lambda () (let ((v (evalms '() c))) 34 | (evalms (list `(b b done) v) `((var 1) (var 0))))))) 35 | 'no 36 | ) 37 | 38 | (test "matcher-trace-1" 39 | (evalms (list 40 | `(delta-eval (lambda _ tie (lambda _ eval (lambda ev l (lambda _ exp (lambda _ env 41 | (if (symbol? exp) (let _ (log 0 exp) (log 0 (((eval l) exp) env))) 42 | ((((tie ev) l) exp) env))))))) 43 | (let maybe-lift (lambda _ e e) ,matcher-src)) 44 | `(_ * a _ * done) `(b a done)) 45 | `((((,pink-eval-exp3 (var 0)) nil-env) (var 1)) (var 2))) 46 | 'yes 47 | ) 48 | 49 | (test "matcher-trace-2" 50 | (evalms (list 51 | `(delta-eval (lambda _ tie (lambda _ eval (lambda ev l (lambda _ exp (lambda _ env 52 | (if (symbol? exp) (let _ (log 0 exp) (log 0 (((eval l) exp) env))) 53 | ((((tie ev) l) exp) env))))))) 54 | (let maybe-lift (lambda _ e e) ,matcher-src)) 55 | `(_ * a _ * done) `(b b done)) 56 | `((((,pink-eval-exp3 (var 0)) nil-env) (var 1)) (var 2))) 57 | 'no 58 | ) 59 | 60 | (define tracing-matcher-transformer 61 | (lambda (r) 62 | (let ((c (reifyc (lambda () (evalms (list 63 | `(delta-eval (lambda _ tie (lambda _ eval (lambda ev l (lambda _ exp (lambda _ env 64 | (if (symbol? exp) (let _ (log (lift 0) exp) (let r (((eval l) exp) env) (let _ (log (lift 0) r) r))) 65 | ((((tie ev) l) exp) env))))))) 66 | (let maybe-lift (lambda _ e (lift e)) ,matcher-src)) 67 | r) 68 | `(((,pink-eval-exp2 (var 0)) nil-env) (var 1))))))) 69 | (run (lambda () (let ((v (evalms '() c))) v)))))) 70 | 71 | 72 | (test "matcher-trace-c-1" 73 | (evalms (list `(b a done) (tracing-matcher-transformer '(_ * a _ * done))) `((var 1) (var 0))) 74 | 'yes 75 | ) 76 | 77 | (test "matcher-trace-c-2" 78 | (evalms (list `(b b done) (tracing-matcher-transformer '(_ * a _ * done))) `((var 1) (var 0))) 79 | 'no 80 | ) 81 | -------------------------------------------------------------------------------- /pink-tests.scm: -------------------------------------------------------------------------------- 1 | (load "base.scm") 2 | (load "pink.scm") 3 | (load "test-check.scm") 4 | 5 | (test "pink-code-1" 6 | (evalms '() (trans `(code? 0 1) '())) 7 | 0 8 | ) 9 | 10 | (test "pink-eval-code-1" 11 | (evalms '((code? 0 1)) `((,pink-eval-exp1 (var 0)) nil-env)) 12 | 0 13 | ) 14 | 15 | (test "pink-code-lift-2" 16 | (evalms '() (trans `(code? 0 (lift 2)) '())) 17 | 1 18 | ) 19 | 20 | (test "pink-eval-code-lift-21" 21 | (evalms '((code? 0 (lift 2))) `((,pink-eval-exp1 (var 0)) nil-env)) 22 | 1 23 | ) 24 | 25 | (test "pink-fac-4" 26 | (evalms '() (trans `(,pink-fac 4) '())) 27 | 24 28 | ) 29 | 30 | (test "pink-eval-fac-4" 31 | (evalms (list pink-fac) `(((,pink-eval-exp1 (var 0)) nil-env) 4)) 32 | 24 33 | ) 34 | 35 | (test "pink-evalc-fac" 36 | (reifyc (lambda () (evalms (list pink-fac) `((,pink-evalc-exp1 (var 0)) nil-env)))) 37 | base-fac-anf 38 | ) 39 | 40 | (test "pink-eval-evalc-fac" 41 | (reifyc (lambda () (evalms (list pink-fac pink-evalc-src) `((((,pink-eval-exp2 (var 1)) nil-env) (var 0)) nil-env)))) 42 | base-fac-anf 43 | ) 44 | 45 | (test "pink-eval-eval-evalc-fac" 46 | (reifyc (lambda () (evalms (list pink-fac pink-evalc-src pink-eval-src) `((((((,pink-eval-exp3 (var 2)) nil-env) (var 1)) nil-env) (var 0)) nil-env)))) 47 | base-fac-anf 48 | ) 49 | 50 | ;; slow but true 51 | ;; (test "pink-eval-eval-eval-evalc-fac" 52 | ;; (reifyc (lambda () (evalms (list pink-fac pink-evalc-src pink-eval-src) `((((((((,pink-eval-exp3 (var 2)) nil-env) (var 2)) nil-env) (var 1)) nil-env) (var 0)) nil-env)))) 53 | ;; base-fac-anf 54 | ;; ) 55 | 56 | (test "pink-evalc-fac-4" 57 | (let ((c (reifyc (lambda () (evalms (list pink-fac) `((,pink-evalc-exp1 (var 0)) nil-env)))))) 58 | (run (lambda () (evalms '() `(,c 4))))) 59 | 24 60 | ) 61 | 62 | (test "pink-self-compilation" 63 | (let ((c (reifyc (lambda () (evalms (list pink-eval-src) `((,pink-evalc-exp1 (var 0)) nil-env)))))) 64 | (run (lambda () (let ((v (evalms '() c))) 65 | (evalms (list pink-fac v) '((((var 1) (var 0)) nil-env) 4)))))) 66 | 24 67 | ) 68 | 69 | (test "pink-trace-fac" 70 | (evalms (list 71 | '((delta-eval (lambda _ tie (lambda _ eval (lambda ev l (lambda _ exp (lambda _ env 72 | (if (if (symbol? exp) (eq? 'n exp) 0) (log ((car l) 0) (((eval l) exp) env)) 73 | ((((tie ev) l) exp) env))))))) 74 | (lambda f n (if n (* n (f (- n 1))) 1))) 4)) 75 | `((,pink-eval-exp1 (var 0)) nil-env)) 76 | 24 77 | ) 78 | 79 | (test "pink-trace-fac-2" 80 | (evalms (list 81 | '(delta-eval (lambda _ tie (lambda _ eval (lambda ev l (lambda _ exp (lambda _ env 82 | (if (if (symbol? exp) (eq? 'n exp) 0) (log ((car l) 0) (((eval l) exp) env)) 83 | ((((tie ev) l) exp) env))))))) 84 | (lambda f n (if n (* n (f (- n 1))) 1)))) 85 | `(((,pink-eval-exp1 (var 0)) nil-env) 4)) 86 | 24 87 | ) 88 | 89 | (test "pink-trace-fac-clambda" 90 | (evalms (list 91 | '(delta-eval (lambda _ tie (lambda _ eval (lambda ev l (lambda _ exp (lambda _ env 92 | (if (if (symbol? exp) (eq? 'n exp) 0) (log ((car l) 0) (((eval l) exp) env)) 93 | ((((tie ev) l) exp) env))))))) 94 | (clambda f n (if n (* n (f (- n 1))) 1)))) 95 | `(((,pink-eval-exp1 (var 0)) nil-env) 4)) 96 | 24 97 | ) 98 | 99 | (test "pink-fac-clambda-code" 100 | (let ((c (evalms (list 101 | '(clambda f n (if n (* n (f (- n 1))) 1))) 102 | `((,pink-eval-exp1 (var 0)) nil-env)))) 103 | (caddr c)) 104 | '(let (if [var 14] 105 | [let (- (var 14) 1) 106 | (let ([var 13] [var 15]) (let (* [var 14] [var 16]) (var 17)))] 107 | 1) 108 | (var 15)) 109 | ) 110 | 111 | (test "pink-trace-fac-clambda-code" 112 | (let ((c (evalms (list 113 | '(delta-eval (lambda _ tie (lambda _ eval (lambda ev l (lambda _ exp (lambda _ env 114 | (if (if (symbol? exp) (eq? 'n exp) 0) (log ((car l) 0) (((eval l) exp) env)) 115 | ((((tie ev) l) exp) env))))))) 116 | (clambda f n (if n (* n (f (- n 1))) 1)))) 117 | `((,pink-eval-exp1 (var 0)) nil-env)))) 118 | (caddr c)) 119 | '(let (log 0 [var 14]) 120 | (let (if 121 | [var 15] 122 | [let (log 0 (var 14)) 123 | (let (log 0 [var 14]) 124 | (let (- [var 17] 1) 125 | (let ([var 13] [var 18]) (let (* [var 16] [var 19]) (var 20)))))] 126 | 1) 127 | (var 16))) 128 | ) 129 | 130 | (test "pink-unlift-oo" 131 | (let ((c 132 | (evalms (list `(clambda _ _ 133 | (let send (unlift (lambda _ o (unlift (lambda _ msg (o msg))))) 134 | (let recv (unlift (lambda _ t t)) 135 | ((send (recv (unlift (lambda _ msg (if (eq? msg 'hi) (lift 'hello) (lift 'error)))))) (unlift 'hi)))))) 136 | `((,pink-eval-exp1 (var 0)) nil-env)) 137 | )) (caddr c)) 138 | 'hello 139 | ) 140 | -------------------------------------------------------------------------------- /pink.scm: -------------------------------------------------------------------------------- 1 | (define last-index 2 | (lambda (e env) 3 | (define iter 4 | (lambda (r i env) 5 | (if (null? env) 6 | (if (= r -1) (error 'last-index (format "unbound variable ~a" e)) r) 7 | (let ((new-r (if (eq? e (car env)) i r))) 8 | (iter new-r (+ i 1) (cdr env)))))) 9 | (iter -1 0 env))) 10 | 11 | (define sug 12 | (lambda (e) 13 | (if (pair? e) 14 | (if (member (car e) '(cadr caddr cadddr)) 15 | (let ((a (sug (cadr e)))) 16 | (cond 17 | ((eq? (car e) 'cadr) `(car (cdr ,a))) 18 | ((eq? (car e) 'caddr) `(car (cdr (cdr ,a)))) 19 | ((eq? (car e) 'cadddr) `(car (cdr (cdr (cdr ,a))))))) 20 | (map sug e)) 21 | e))) 22 | 23 | (define trans 24 | (lambda (e env) 25 | (cond 26 | ((number? e) e) 27 | ((symbol? e) `(var ,(last-index e env))) 28 | (((tagged? 'quote) e) (cadr e)) 29 | (((tagged? 'lambda) e) `(lambda ,(trans (cadddr e) (append env (list (cadr e) (caddr e)))))) 30 | (((tagged? 'let) e) `(let ,(trans (caddr e) env) ,(trans (cadddr e) (append env (list (cadr e)))))) 31 | ((and (pair? e) (member (car e) '(if + - * eq? number? symbol? pair? null? code? cons car cdr run lift lift-ref log))) 32 | (cons (car e) (map (lambda (x) (trans x env)) (cdr e)))) 33 | (else (map (lambda (x) (trans x env)) e))))) 34 | 35 | (define pink-poly-src 36 | '(lambda tie eval (lambda _ l (lambda _ exp (lambda _ env 37 | (if (number? exp) ((car l) exp) 38 | (if (symbol? exp) (env exp) 39 | (if (symbol? (car exp)) 40 | (if (eq? '+ (car exp)) (+ (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env)) 41 | (if (eq? '- (car exp)) (- (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env)) 42 | (if (eq? '* (car exp)) (* (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env)) 43 | (if (eq? 'eq? (car exp)) (eq? (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env)) 44 | (if (eq? 'if (car exp)) (if (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env) (((eval l) (cadddr exp)) env)) 45 | (if (if (eq? 'lambda (car exp)) 1 (if (eq? 'clambda (car exp)) (cdr l) 0)) ((car l) (lambda f x (((eval l) (cadddr exp)) 46 | (lambda _ y (if (eq? y (cadr exp)) f (if (eq? y (caddr exp)) x (env y))))))) 47 | (if (eq? 'clambda (car exp)) (run 0 (((eval (cons (lambda _ e (lift e)) 1)) (cons 'lambda (cdr exp))) (lambda _ y (lift-ref y (env y))))) 48 | (if (eq? 'let (car exp)) (let x (((eval l) (caddr exp)) env) (((eval l) (cadddr exp)) 49 | (lambda _ y (if (eq? y (cadr exp)) x (env y))))) 50 | (if (eq? 'lift (car exp)) (lift (((eval l) (cadr exp)) env)) 51 | (if (eq? 'unlift (car exp)) (((eval (cons (lambda _ e e) 0)) (cadr exp)) env) 52 | (if (eq? 'lift-ref (car exp)) (lift-ref (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env)) 53 | (if (eq? 'log (car exp)) (log (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env)) 54 | (if (eq? 'number? (car exp)) (number? (((eval l) (cadr exp)) env)) 55 | (if (eq? 'symbol? (car exp)) (symbol? (((eval l) (cadr exp)) env)) 56 | (if (eq? 'null? (car exp)) (null? (((eval l) (cadr exp)) env)) 57 | (if (eq? 'pair? (car exp)) (pair? (((eval l) (cadr exp)) env)) 58 | (if (eq? 'code? (car exp)) (code? (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env)) 59 | (if (eq? 'car (car exp)) (car (((eval l) (cadr exp)) env)) 60 | (if (eq? 'cdr (car exp)) (cdr (((eval l) (cadr exp)) env)) 61 | (if (eq? 'cons (car exp)) ((car l) (cons (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env))) 62 | (if (eq? 'quote (car exp)) ((car l) (cadr exp)) 63 | (if (eq? 'run (car exp)) (run (((eval l) (cadr exp)) env) (((eval l) (caddr exp)) env)) 64 | (if (eq? 'delta (car exp)) 65 | (let ev (((eval (cons (lambda _ e e) (cdr l))) (cadr exp)) env) (((ev l) (caddr exp)) env)) 66 | (if (eq? 'delta-eval (car exp)) 67 | (let ev (((eval (cons (lambda _ e e) (cdr l))) (cadr exp)) env) (((((ev tie) eval) l) (caddr exp)) env)) 68 | ((env (car exp)) (((eval l) (cadr exp)) env)))))))))))))))))))))))))) 69 | ((((eval l) (car exp)) env) (((eval l) (cadr exp)) env))))))))) 70 | ) 71 | 72 | (define pink-fac '(lambda f n (if n (* n (f (- n 1))) 1))) 73 | 74 | (define pink-tie-src 75 | (sug `(lambda eval l (lambda _ e (((,pink-poly-src eval) l) e))))) 76 | 77 | (define pink-eval-src 78 | `(,pink-tie-src (cons (lambda _ e e) 0))) 79 | 80 | (define pink-evalc-src 81 | `(,pink-tie-src (cons (lambda _ e (lift e)) 0))) 82 | 83 | (define pink-eval-exp1 84 | (trans pink-eval-src '(arg1))) 85 | 86 | (define pink-eval-exp2 87 | (trans pink-eval-src '(arg1 arg2))) 88 | 89 | (define pink-eval-exp3 90 | (trans pink-eval-src '(arg1 arg2 arg3))) 91 | 92 | (define pink-evalc-exp1 93 | (trans pink-evalc-src '(arg1))) 94 | 95 | (define pink-evalc-exp2 96 | (trans pink-evalc-src '(arg1 arg2))) 97 | 98 | (define pink-evalc-exp3 99 | (trans pink-evalc-src '(arg1 arg2 arg3))) 100 | -------------------------------------------------------------------------------- /base.scm: -------------------------------------------------------------------------------- 1 | (define tagged? (lambda (t) (lambda (e) (and (pair? e) (eq? (car e) t))))) 2 | (define s (lambda (e) 3 | (cond 4 | (((tagged? 'clo) e) `(clo _ ,(caddr e))) 5 | ((pair? e) (cons (s (car e)) (s (cdr e)))) 6 | (else e)))) 7 | (define code? (tagged? 'code)) 8 | (define code-exp cadr) 9 | (define force-code 10 | (lambda (f) 11 | (if (code? f) (code-exp f) 12 | (error 'force-code (format "expected code, not ~a" (s f)))))) 13 | 14 | (define make-let (lambda (e1 e2) `(let ,e1 ,e2))) 15 | 16 | (define stFresh 0) 17 | (define stBlock '()) ;; List[Exp] 18 | (define stFun '()) ;; List[(Int,Env,Exp)] 19 | 20 | (define reset! 21 | (lambda () 22 | (set! stFresh 0) 23 | (set! stBlock '()) 24 | (set! stFun '()))) 25 | 26 | (define run 27 | (lambda (thunk) 28 | (let ((sF stFresh) 29 | (sB stBlock) 30 | (sN stFun)) 31 | (let ((r (thunk))) 32 | (set! stFresh sF) 33 | (set! stBlock sB) 34 | (set! stFun sN) 35 | r)))) 36 | 37 | (define fresh 38 | (lambda () 39 | (set! stFresh (+ 1 stFresh)) 40 | `(var ,(- stFresh 1)))) 41 | 42 | (define reify 43 | (lambda (thunk) 44 | (run (lambda () 45 | (set! stBlock '()) 46 | (let ((last (thunk))) 47 | (fold-right make-let last stBlock)))))) 48 | 49 | (define reflect 50 | (lambda (s) 51 | (set! stBlock (append stBlock (list s))) 52 | (fresh))) 53 | 54 | (define reifyc 55 | (lambda (thunk) 56 | (reify (lambda () (force-code (thunk)))))) 57 | 58 | (define reflectc 59 | (lambda (s) `(code ,(reflect s)))) 60 | 61 | (define reifyv 62 | (lambda (thunk) 63 | (run (lambda () 64 | (set! stBlock '()) 65 | (let ((res (thunk))) 66 | (if (not (null? stBlock)) 67 | ;; if we are generating code at all 68 | ;; the result must be code 69 | (let ((last (force-code res))) 70 | `(code ,(fold-right make-let last stBlock))) 71 | res)))))) 72 | 73 | 74 | (define findFun 75 | (lambda (v) 76 | (let ((env (cadr v)) 77 | (e (caddr v))) 78 | (define iter 79 | (lambda (fs) 80 | (if (null? fs) 81 | #f 82 | (let ((f (car fs))) 83 | (if (and (equal? env (cadr f)) (equal? e (caddr f))) 84 | (car f) 85 | (iter (cdr fs))))))) 86 | (iter stFun)))) 87 | 88 | ;; NBE-style reify operator (semantics -> syntax) 89 | (define lift 90 | (lambda (v) 91 | (cond 92 | ((number? v) v) 93 | ((symbol? v) v) 94 | (((tagged? 'clo) v) 95 | (let ((n (findFun v))) 96 | (if n `(var ,n) 97 | (let ((env2 (cadr v)) 98 | (e2 (caddr v))) 99 | (set! stFun (append stFun (list (list stFresh env2 e2)))) 100 | (reflect 101 | `(lambda ,(reify 102 | (lambda () 103 | (force-code (evalms 104 | (append env2 `((code ,(fresh)) (code ,(fresh)))) 105 | e2)))))))))) 106 | ((code? v) (reflect `(lift ,(force-code v)))) 107 | ((pair? v) 108 | (let ((a (force-code (car v))) 109 | (b (force-code (cdr v)))) 110 | (reflect `(cons ,a ,b))))))) 111 | 112 | ;; this is basically nth! 113 | (define lookup 114 | (lambda (env n) 115 | (if (null? env) (error 'lookup "unbound variable") 116 | (if (= n 0) (car env) 117 | (lookup (cdr env) (- n 1)))))) 118 | 119 | (define binary-op 120 | (lambda (fun) 121 | (lambda (env e) 122 | ;; Use let* to enforce evaluation order. 123 | (let* ((v1 (evalms env (cadr e))) 124 | (v2 (evalms env (caddr e)))) 125 | (if (and (code? v1) (code? v2)) 126 | (reflectc (list (car e) (force-code v1) (force-code v2))) 127 | (if (and (not (code? v1)) (not (code? v2))) 128 | (fun v1 v2) 129 | (error 'binary-op (format "stage error in ~a ~a ~a" (car e) (s v1) (s v2))))))))) 130 | 131 | (define unary-op 132 | (lambda (fun) 133 | (lambda (env e) 134 | (let ((v1 (evalms env (cadr e)))) 135 | (if (code? v1) 136 | (reflectc (list (car e) (force-code v1))) 137 | (fun v1)))))) 138 | 139 | (define b2n (lambda (r) (if r 1 0))) 140 | 141 | (define pred-op 142 | (lambda (fun) 143 | (lambda (env e) 144 | (let ((v1 (evalms env (cadr e)))) 145 | (if (code? v1) 146 | (reflectc (list (car e) (force-code v1))) 147 | (b2n (fun v1))))))) 148 | 149 | (define log (lambda (e) (begin (display (s e)) (newline) e))) 150 | 151 | (define lift-ref (lambda (e1 e2) 152 | `(code (proc ,e1 ,(lambda (ignore) (e2)))))) 153 | 154 | (define evalms 155 | (lambda (env e) 156 | (cond 157 | ((number? e) e) 158 | ((symbol? e) e) 159 | (((tagged? 'proc) e) ((caddr e) env)) 160 | (((tagged? 'var) e) (lookup env (cadr e))) 161 | (((tagged? 'lambda) e) `(clo ,env ,(cadr e))) 162 | (((tagged? 'let) e) 163 | (let ((v1 (evalms env (cadr e)))) 164 | (evalms (append env (list v1)) (caddr e)))) 165 | (((tagged? 'lift) e) 166 | `(code ,(lift (evalms env (cadr e))))) 167 | (((tagged? 'lift-ref) e) 168 | (lift-ref (evalms env (cadr e)) (lambda () (evalms env (caddr e))))) 169 | (((tagged? 'run) e) 170 | (let ((v1 (evalms env (cadr e))) 171 | (thunk (lambda () (evalms env (caddr e))))) 172 | (if (code? v1) 173 | (reflectc `(run ,(force-code v1) ,(reifyc thunk))) 174 | (reifyv (lambda () (evalms env (reifyc (lambda () (set! stFresh (length env)) (thunk))))))))) 175 | (((tagged? 'code?) e) 176 | (let ((v1 (evalms env (cadr e))) 177 | (v2 (evalms env (caddr e)))) 178 | (if (code? v1) 179 | (reflectc `(code? ,(force-code v1) ,(force-code v2))) 180 | (b2n (code? v2))))) 181 | (((tagged? 'log) e) 182 | (let ((v1 (evalms env (cadr e))) 183 | (v2 (evalms env (caddr e)))) 184 | (if (code? v1) 185 | (reflectc `(log ,(force-code v1) ,(force-code (if (code? v2) v2 (lift-ref '_ (lambda () v2)))))) 186 | (log v2)))) 187 | (((tagged? 'if) e) 188 | (let ((vc (evalms env (cadr e)))) 189 | (if (code? vc) 190 | (reflectc `(if ,(force-code vc) 191 | ,(reifyc (lambda () (evalms env (caddr e)))) 192 | ,(reifyc (lambda () (evalms env (cadddr e)))))) 193 | (if (number? vc) 194 | (if (not (= vc 0)) (evalms env (caddr e)) (evalms env (cadddr e))) 195 | (error 'evalms (format "if expects number for condition, not ~a in ~a" (s vc) (s e))))))) 196 | (((tagged? '+) e) ((binary-op +) env e)) 197 | (((tagged? '-) e) ((binary-op -) env e)) 198 | (((tagged? '*) e) ((binary-op *) env e)) 199 | (((tagged? 'eq?) e) ((binary-op (lambda (x y) (b2n (eq? x y)))) env e)) 200 | (((tagged? 'car) e) ((unary-op car) env e)) 201 | (((tagged? 'cdr) e) ((unary-op cdr) env e)) 202 | (((tagged? 'number?) e) ((pred-op number?) env e)) 203 | (((tagged? 'symbol?) e) ((pred-op symbol?) env e)) 204 | (((tagged? 'pair?) e) ((pred-op pair?) env e)) 205 | (((tagged? 'null?) e) ((pred-op null?) env e)) 206 | ;; cons is an introduction form, so needs explicit lifting 207 | (((tagged? 'cons) e) (cons (evalms env (cadr e)) (evalms env (caddr e)))) 208 | (else ;; assume application 209 | (let ((v1 (evalms env (car e))) 210 | (v2 (evalms env (cadr e)))) 211 | (if (and (code? v1) (code? v2)) 212 | `(code ,(reflect `(,(force-code v1) ,(force-code v2)))) 213 | (if ((tagged? 'clo) v1) 214 | (evalms (append (cadr v1) (list v1 v2)) (caddr v1)) 215 | (error 'evalms (format "app expects closure, not ~a in ~a" (s v1) (s e)))))))))) 216 | 217 | (define base-fac-anf 218 | '(let (lambda 219 | (let (if (var 1) 220 | (let (- (var 1) 1) 221 | (let ((var 0) (var 2)) (let (* (var 1) (var 3)) (var 4)))) 222 | 1) 223 | (var 2))) 224 | (var 0))) 225 | --------------------------------------------------------------------------------