Last active
January 3, 2016 19:39
-
-
Save ojarjur/8510276 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(define (cps expr) | |
(define (cps-arg arg) | |
(if (and (pair? arg) (not (eq? (car arg) 'lambda))) | |
`(let ((pending? #t) | |
(arg-val '<undefined>)) | |
(lambda (k) | |
(if pending? | |
,(cps-nested arg | |
(lambda (arg-code) | |
`(begin (set! pending? #f) | |
(set! arg-val ,arg-code) | |
(k arg-val)))) | |
(k arg-val)))) | |
(cps-tail-call arg))) | |
(define (cps-arg-list arg-list) | |
(if (pair? arg-list) | |
(cons (cps-arg (car arg-list)) | |
(cps-arg-list (cdr arg-list))) | |
'())) | |
(define (cps-atom-nested expr builder) | |
(if (symbol? expr) | |
`(,expr (lambda (v) ,(builder 'v))) | |
(builder expr))) | |
(define (cps-lambda-nested params body builder) | |
(builder `(lambda ,params ,(cps-tail-call body)))) | |
(define (cps-application-nested op args builder) | |
(cps-nested op (lambda (op-code) | |
`(,(cons op-code (cps-arg-list args)) | |
(lambda (v) ,(builder 'v)))))) | |
(define (cps-nested expr builder) | |
(if (pair? expr) | |
(if (eq? (car expr) 'lambda) | |
(cps-lambda-nested (cadr expr) (caddr expr) builder) | |
(cps-application-nested (car expr) (cdr expr) builder)) | |
(cps-atom-nested expr builder))) | |
(define (cps-atom-tail-call expr cont) | |
(if (symbol? expr) | |
`(,expr ,cont) | |
`(,cont ,expr))) | |
(define (cps-lambda-tail-call params body cont) | |
`(,cont (lambda ,params ,(cps-tail-call body)))) | |
(define (cps-application-tail-call op args cont) | |
(cps-nested op (lambda (op-code) | |
`(,(cons op-code (cps-arg-list args)) ,cont)))) | |
(define (cps-tail-call expr) | |
`(lambda (k) | |
,(if (pair? expr) | |
(if (eq? (car expr) 'lambda) | |
(cps-lambda-tail-call (cadr expr) (caddr expr) 'k) | |
(cps-application-tail-call (car expr) (cdr expr) 'k)) | |
(cps-atom-tail-call expr 'k)))) | |
(if (and (pair? expr) (eq? (car expr) 'define)) | |
`(define ,(cadr expr) ,(cps-tail-call (caddr expr))) | |
`(,(cps-tail-call expr) (lambda (val) val)))) | |
(define (lazy-repl environment) | |
(begin (display "> ") | |
(let ((expr (read))) | |
(if (not (eof-object? expr)) | |
(begin (display (eval (cps expr) environment)) | |
(newline) | |
(lazy-repl environment)))))) | |
(lazy-repl (interaction-environment)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment