implementing a lisp-1 with call/cc in SBCL

cps.lisp

(defvar *env* `((t . t)
                ,@(mapcar
                   (lambda (x) `(,x . ,(symbol-function x)))
                   '(+ - * / cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
                     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar
                     cddadr cdddar cddddr eq list list* read not prin1 print write-string))
                (get-meta-lvl . ,(lambda () *meta-lvl*))
                (eval . ,(lambda (x) (let ((*meta-lvl* (1+ *meta-lvl*))) (eval-env x *env*))))))

(defun map& (f list k)
  (cond
    ((not list) (funcall k nil))
    ((consp list) (funcall f (car list) (lambda (v) (map& f (cdr list) (lambda (w) (funcall k (cons v w)))))))))

(defun apply& (f args k)
  (if (not (consp f))
      (funcall k (apply f args))
      (if (eq 'meta-cc (car f))
          (apply (cadr f) args)
          (let ((bound `(,@(mapcar #'cons (caddr f) args) ,@ (cadr f))))
            (map& (lambda (x k) (eval& x bound k)) (cdddr f)
                  (lambda (v) (funcall k (car (last v)))))))))

(defun eval& (form env k)
  (labels ((eval-with-env& (form k) (eval& form env k))
           (do-list-with-env& (x k) (map& #'eval-with-env& x (lambda (v) (funcall k (car (last v))))))
           (eval-quasi& (form k)
             (cond ((sb-int:comma-p form) (eval-with-env& (sb-int:comma-expr form) k))
                   ((consp form) (map& #'eval-quasi& form k))
                   (t (funcall k form)))))
    (cond
      ((symbolp form) (funcall k (cdr (assoc form env))))
      ((consp form)
       (cond
         ((and (symbolp (car form)) (assoc (car form) env))
          (eval-with-env& (car form) (lambda (v) (map& #'eval-with-env& (cdr form)
                                                       (lambda (w) (apply& v w k))))))
         ((eq (car form) 'call/cc) (eval-with-env& (cadr form)
                                                   (lambda (f)
                                                     (eval-with-env& `(,f (meta-cc ,k)) k))))
         ((eq (car form) 'lambda) (funcall k `(closure ,env ,@(cdr form))))
         ((eq (car form) 'closure) (funcall k form))
         ((eq (car form) 'meta-cc) (funcall k form))
         ((eq (car form) 'quote) (funcall k (cadr form)))
         ((eq (car form) 'sb-int:quasiquote) (eval-quasi& (cadr form) k))
         ((eq (car form) 'progn) (do-list-with-env& (cdr form) k))
         ((eq (car form) 'loop)
          (labels ((l (k)
                     (do-list-with-env& (cdr form)
                       (lambda (v) (if (eq 'quit v) (funcall k 'quit) (l k))))))
            (l k)))
         ((eq (car form) 'let)
          (map&
           (lambda (x k) (do-list-with-env& (cdr x) (lambda (v) (funcall k (cons (car x) v)))))
           (cadr form)
           (lambda (q) (eval-with-env& `((closure (,@q ,@env) () ,@(cddr form))) k))))
         ((eq (car form) 'if) (eval-with-env&
                               (cadr form)
                               (lambda (b) (eval-with-env& (if b (caddr form) (cadddr form)) k))))
         (t (eval-with-env& (car form) (lambda (f)
                                         (map& #'eval-with-env& (cdr form)
                                               (lambda (args) (apply& f args k))))))))
      (t (funcall k form)))))

(defun repl-cps ()
  (labels ((l ()
             (write-string "
object > ")  (eval& (read) *env* (lambda (v) (if (eq v 'quit) 'quit (progn (prin1 v) (l)))))))
    (l)))