継続渡しスタイルの勉強と実験。

cps-modoki.lisp

(defun -& (ak bk k)
  "引き算 (継続版)。
値を得る継続 (ak, bk) から得た値で引き算して、それを次の継続に渡す"
  (funcall (funcall (lambda (a)
                      (lambda (b)
                        (funcall k (- a b))))
                    (funcall ak (lambda (v) v)))
           (funcall bk (lambda (v) v))))

(defun +& (ak bk k)
  "足し算 (継続版)"
  (funcall (funcall (lambda (a)
                      (lambda (b)
                        (funcall k (- a b))))
                    (funcall ak (lambda (v) v)))
           (funcall bk (lambda (v) v))))

(defun to-cps%v1 (form)
  "funcallすると最後の計算まで一気に突っ走るCPS変換もどき。関数適用とリテラルのみ対応。"
  (if (atom form)
      (let ((k$ (gensym)))
        `#'(lambda (,k$)
             (funcall ,k$ ,form)))
      (let* ((op (first form))
             (op& (intern (format nil "~a&" (symbol-name op))))
             (argv (rest form))
             (argv$ (mapcar (lambda (_) (declare (ignore _)) (gensym)) argv))
             (k$ (gensym)))
        `(lambda (,k$)
           ,(loop
              :named make-funcall
              :with f := (loop
                           :named make-lambda
                           :with f := `(funcall #',op& ,@argv$ ,k$)
                           :for arg$ :in argv$
                           :for i := 0 :then (incf i)
                           :do (setf f `(lambda (,arg$) ,f))
                           :finally (return-from make-lambda f))
              :for arg :in (reverse argv)
              :do (setf f `(funcall ,f ,(to-cps%v1 arg)))
              :finally (return-from make-funcall f))))))

(defun -&v2 (ak bk k run)
  (funcall (funcall (lambda (a)
                      (lambda (b)
                        (funcall k (- a b) run)))
                    (funcall ak (lambda (v _) (declare (ignore _)) v) run))
           (funcall bk (lambda (v _) (declare (ignore _)) v) run)))

(defun +&v2 (ak bk k run)
  (funcall (funcall (lambda (a)
                      (lambda (b)
                        (funcall k (+ a b) run)))
                    (funcall ak (lambda (v _) (declare (ignore _)) v) run))
           (funcall bk (lambda (v _) (declare (ignore _)) v) run)))

(defun to-cps%v2 (form)
  "funcallすると1ステップごとにその瞬間の継続を返して止まる版をつくってるつもりだった。と、止まんねぇ〜〜〜。"
  (if (atom form)
      (let ((k$ (gensym))
            (run$ (gensym)))
        `#'(lambda (,k$ ,run$)
             (funcall ,run$ :atom ,k$ ,run$ ,form)))
      (let* ((op (first form))
             (op& (intern (format nil "~a&V2" (symbol-name op))))
             (argv (rest form))
             (argv$ (mapcar (lambda (_) (declare (ignore _)) (gensym)) argv))
             (k$ (gensym))
             (run$ (gensym)))
        `(lambda (,k$ ,run$)
           ,(loop
              :named make-funcall
              :with f := (loop
                           :named make-lambda
                           :with f := `(funcall ,run$ :apply ,k$ ,run$ #',op& ,@argv$)
                           :for arg$ :in argv$
                           :for i := 0 :then (incf i)
                           :do (setf f `(lambda (,arg$) ,f))
                           :finally (return-from make-lambda f))
              :for arg :in (reverse argv)
              :do (setf f `(funcall ,f ,(to-cps%v2 arg)))
              :finally (return-from make-funcall f))))))

(defun run-cps%v2 (form)
  (flet ((lastk (v _)
           (declare (ignore _))
           v)
         (run (type k run &rest args)
           (print (list type k run args))
           (case type
             (:atom (apply k `(,(first args) ,run)))
             (:apply (destructuring-bind (op &rest args)
                         args
                       (apply op `(,@args ,k ,run)))))))
    (let ((form% (to-cps%v2 form)))
      (format t "form: ~s~%" form)
      (format t "cps: ~s~%" form%)
      (funcall (eval form%) #'lastk #'run))))