Call-by-need lambda-calculus interpreter.scm

(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))