delimited continuation macro transformer

dcont.lisp

(defpackage #:delimited-continuations
  (:use #:cl)
  (:export #:with/dc #:reset #:shift))

(in-package #:delimited-continuations)

(defmacro letcont ((&whole binding name lambda-list &body cbody) &body body)
  (let ((old (gensym "OLD")))
    (multiple-value-bind (cforms cdecls)
        (alexandria:parse-body cbody :whole binding)
      `(let* ((,old *cont*)
              (,name (lambda ,lambda-list
                       ,@cdecls
                       (let ((*cont* ,old)) ,@cforms))))
         ,@body))))

(defun %dc/lambda (lambda-list body env)
  ;; FIXME: Should augment the environment with the lambda list
  ;; (e.g. in case symbol macros are shadowed)
  (multiple-value-bind (body decls doc)
      (alexandria:parse-body body :documentation t
                                  :whole `(lambda ,lambda-list ,@body))
    `(lambda ,lambda-list ,@decls ,@(when doc (list doc)) ,(%dclis body env))))

(defun %dc/fhead (fname env)
  (etypecase fname
    (symbol fname)
    ((cons (eql lambda)) (%dc/lambda (second fname) (cddr fname) env))))

(defun %dc/call (fname argforms env)
  (loop with argsyms = (loop repeat (length argforms) collect (gensym "ARG"))
        with real-f = (%dc/fhead fname env)
        with form = `(,real-f ,@argsyms)
        with csym = (gensym "CONT")
        with ign = (gensym "IGNORE")
        for rargf in (reverse argforms)
        for rargsym in (reverse argsyms)
        do (setf form
                 `(letcont (,csym (&optional ,rargsym &rest ,ign)
                             (declare (ignore ,ign))
                             ,form)
                    (funcall ,csym (let ((*cont* ,csym)) ,(%dc rargf env)))))
        finally (return form)))

(defun %dc/mvc (fname argforms env)
  (loop with argsyms = (loop repeat (length argforms) collect (gensym "ARG"))
        with real-f = (%dc/fhead fname env)
        with form = `(multiple-value-call #',real-f
                       ,@(loop for asym in argsyms
                               collect `(values-list ,asym)))
        with csym = (gensym "CONT")
        for rargf in (reverse argforms)
        for rargsym in (reverse argsyms)
        do (setf form
                 `(letcont (,csym (&rest ,rargsym) ,form)
                    (multiple-value-call ,csym
                      (let ((*cont* ,csym)) ,(%dc rargf env)))))
        finally (return form)))

(defun %dc/let (bindings body env)
  ;; cheap out
  (let ((names (loop for binding in bindings
                     collect (etypecase binding
                               (symbol binding)
                               ((cons symbol) (first binding)))))
        (vforms (loop for binding in bindings
                      collect (etypecase binding
                                (symbol binding)
                                ((cons symbol (cons t null))
                                 (second binding))))))
    (%dc `((lambda (,@names) ,@body) ,@vforms) env)))

(defun function-block-name (fname)
  ;; Doesn't account for implementation extension. RIP
  (etypecase fname
    (symbol fname)
    ((cons (eql setf) (cons symbol null)) (second fname))))

(defun %dc/flet (bindings body env)
  (multiple-value-bind (body decls)
      (alexandria:parse-body body :whole `(flet ,bindings ,@body))
    `(flet (,@(loop for (name lambda-list . body) in bindings
                    ;; FIXME: as with LAMBDA, we should shadow vars.
                    collect `(,name ,lambda-list ,(%dclis body env))))
       ,@decls
       ;; and should shadow function names
       ,(%dclis body env))))

(defun %dc/function (thing env)
  (etypecase thing
    ((or symbol (cons (eql setf) (cons symbol null))) `(function ,thing))
    ((cons (eql lambda))
     `(function ,(%dc/lambda (second thing) (cddr thing) env)))))

(defun %dc/block (blockname body env)
  `(block ,blockname ,(%dclis body env)))
(defun %dc/catch (tag body env)
  (let ((csym (gensym "CONT")) (gtag (gensym "TAG")) (ign (gensym "IGNORE")))
    `(letcont (,csym (&optional ,gtag &rest ,ign)
                (declare (ignore ,ign))
                (catch ,gtag ,(%dclis body env)))
       (funcall ,csym (let ((*cont* ,csym)) ,tag)))))

(defun %dc/if (condition then else env)
  (let ((csym (gensym "CONT")) (old (gensym "OLD"))
        (gcond (gensym "CONDITION")) (ign (gensym "IGNORE")))
    `(let* ((,old *cont*)
            (,csym (lambda (&optional ,gcond &rest ,ign)
                     (declare (ignore ,ign))
                     (let ((*cont* ,old))
                       (if ,gcond ,(%dc then env) ,(%dc else env))))))
       (funcall ,csym (let ((*cont* ,csym)) ,condition)))))

(defun %dc/eval-when (situations body env)
  ;; we are not at top level
  (if (member :execute situations)
      (%dclis body env)
      'nil))

(defun %dc/mvp1 (first-form forms env)
  (let ((csym (gensym "CONT")) (vals (gensym "VALS")))
    `(letcont (,csym (&rest ,vals) ,(%dclis forms env) (values-list ,vals))
       (multiple-value-prog1
           (let ((*cont* ,csym)) ,(%dc first-form env))
         (funcall ,csym)))))

(defun %dc/return-from (bname result env)
  (let ((vals (gensym "VALS")))
    ;; we don't actually need to preserve the old continuation here, so we use
    ;; LET directly.
    ;; Note that if the BLOCK appears within the RESET we will be returning to
    ;; a continuation's block, so extent is all fine.
    `(let ((*cont* (lambda (&rest ,vals)
                     (return-from ,bname (values-list ,vals)))))
       (return-from ,bname ,(%dc result env)))))

(defun %dc/%setq (name form env)
  (multiple-value-bind (expansion expanded) (macroexpand name env)
    (if expanded
        (%dc `(setf ,expansion ,form) env)
        (let ((csym (gensym "CONT"))
              (val (gensym "VAL")) (ign (gensym "IGNORE")))
          `(letcont (,csym (&optional ,val &rest ,ign)
                      (declare (ignore ,ign))
                      (setq ,name ,val))
             (funcall ,csym (let ((*cont* ,csym)) ,(%dc form env))))))))

(defun %dc/setq (names-and-forms env)
  (loop for (name form) on names-and-forms by #'cddr
        collect `(%setq ,name ,form) into setqs
        finally (return (%dclis setqs env))))

(defun %dc/the (type form env) `(the ,type ,(%dc form env)))

(defun %dc/throw (tag result env)
  (let ((csym (gensym "CONT")) (gtag (gensym "TAG")) (vals (gensym "VALS")))
    `(letcont (,csym (&optional ,gtag &rest ,vals)
                (declare (ignore ,vals))
                ;; See note on RETURN-FROM, above.
                (let ((*cont* (lambda (&rest ,vals)
                                (throw ,gtag (values-list ,vals)))))
                  (throw ,gtag ,(%dc result env))))
       (funcall ,csym (let ((*cont* ,csym)) ,(%dc tag env))))))

;;; not sure about this one
(defun %dc/unwind-protect (protected cleanup env)
  (let ((csym (gensym "CONT")) (gcleanup (gensym "CLEANUP"))
        (old (gensym "OLD")) (vals (gensym "VALS")))
    `(let ((,old *cont*))
       (flet ((,gcleanup () (let ((*cont* ,old)) ,(%dclis cleanup env))))
         (let ((,csym (lambda (&rest ,vals) (,gcleanup) (values-list ,vals))))
           (unwind-protect (let ((*cont* ,csym)) ,(%dc protected env))
             (,gcleanup)))))))

(defun %dc/locally (body env)
  (multiple-value-bind (body decls)
      (alexandria:parse-body body :whole `(locally ,body))
    `(locally ,@decls ,(%dclis body env))))

(defun %dc/reset (body env)
  `(reset ,(%dclis body env)))
(defun %dc/shift (name body env)
  ;; FIXME: shadow the name
  `(shift ,name ,(%dclis body env)))

(defun %dc (form env)
  (typecase form
    (symbol form)
    (cons
     (let ((head (car form)) (rest (cdr form)))
       (case head
         ((block) (%dc/block (first rest) (rest rest) env))
         ((catch) (%dc/catch (first rest) (rest rest) env))
         ((eval-when) (%dc/eval-when (first rest) (rest rest) env))
         ((flet) (%dc/flet (first rest) (rest rest) env))
         ((function) (%dc/function (first rest) env))
         ((if) (%dc/if (first rest) (second rest) (third rest) env))
         ((let) (%dc/let (first rest) (rest rest) env))
         ((load-time-value) #|LTV runs in a different dynenv |# form)
         ((locally) (%dc/locally rest env))
         ((multiple-value-call) (%dc/mvc (first rest) (rest rest) env))
         ((multiple-value-prog1) (%dc/mvp1 (first rest) (rest rest) env))
         ((progn) (%dclis rest env))
         ((quote) form)
         ((return-from) (%dc/return-from (first rest) (second rest) env))
         ((setq) (%dc/setq rest env))
         ((%setq) (%dc/%setq (first rest) (second rest) env))
         ((the) (%dc/the (first rest) (second rest) env))
         ((unwind-protect) (%dc/unwind-protect (first rest) (rest rest) env))
         ;; handle these as "special operators"
         ((reset) (%dc/reset rest env))
         ((shift) (%dc/shift (first rest) (rest rest) env))
         (otherwise
          (multiple-value-bind (expansion expanded) (macroexpand form env)
            (cond (expanded (%dc expansion env))
                  ((special-operator-p head)
                   (error "Special operator ~s not implemented" head))
                  (t (%dc/call head rest env))))))))
    (t form)))

(defun %dclis (forms env)
  (cond ((null forms) nil)
        ((null (rest forms)) (%dc (first forms) env))
        (t (let ((csym (gensym "CONT")) (old (gensym "OLD"))
                 (ign (gensym "IGNORED")))
             `(let* ((,old *cont*)
                     (,csym (lambda (&rest ,ign)
                              (declare (ignore ,ign))
                              (let ((*cont* ,old))
                                ,(%dclis (rest forms) env)))))
                (let ((*cont* ,csym)) ,(%dc (first forms) env))
                (funcall ,csym))))))

(defvar *cont* #'values)

(defmacro reset (&body body)
  `(let ((*cont* #'values))
     (catch 'reset ,@body)))

(defmacro with/dc (&body body &environment env) (%dclis body env))

(defmacro shift (name &body body)
  (let ((csym (gensym "CONT")))
    `(throw 'reset
       (let ((,csym *cont*))
         ;; if the continuation shifts, we want it to return here, rather
         ;; than abort us all the way up to the actual reset. thus the catch.
         (flet ((,name (&rest args) (catch 'reset (apply ,csym args))))
           ,@body)))))