CL-STM

Walking 

Interface 

(defgeneric stm (form)
  (:documentation "Translate FORM into an STM action.

Define methods on this generic function with DEFSTM-WALKER.")
  (:method (form)
    "If FORM isn't a FORM object, we'll convert it to one, apply
the transformation and convert it back."
    (unwalk-form (stm (walk-form form)))))

(defgeneric unstm (form)
  (:documentation "Translate FORM from a STM action to a Lisp
form.

Define methods on this generic function with DEFUNSTM-WALKER."))

(defmacro with-stm (form)
  "Execute FORM as if it were run in the STM."
  (stm form))

Current form 

(defvar *form* nil
  "This contains the current form that is being walked.")

Defining 

(defmacro defstm-walker (class (&rest slots) &body body)
  "Define a STM walker.

It takes the class of a CL form object, and its slots as
arguments.  It binds the form object to the variable *FORM*."
  (with-unique-names (form)
    `(defmethod stm ((,form ,class))
       (let1 *form* ,form
         (with-slots ,slots *form*
           ,@body)))))

(defmacro defunstm-walker (class (&rest slots) &body body)
  "Define a UNSTM walker.

It takes the class of a CL form object, and its slots as
arguments.  It binds the form object to the variable *FORM*."
  (with-unique-names (form)
    `(defmethod unstm ((,form ,class))
       (let1 *form* ,form
         (with-slots ,slots *form*
           ,@body)))))

Special Variables 

(defvar *trans-funs* '(sequence orelse retry)
  "When walking code, this variable contains a list of
functions (represented by symbols) which return transactions when
applied.")

(defmacro with-trans-funs (funs &body body)
  `(let1 *trans-funs* (append *trans-funs* ,funs)
     ,@body))

New forms 

(defclass trans-form (form)
  ((form :accessor form
         :initarg :form)))

(defclass untrans-form (form)
  ((form :accessor form
         :initarg :form)))

(defwalker-handler trans (form parent env)
  (unless (= 2 (length form))
    (error "Invalid TRANS form ~A" form))
  (new 'trans-form
       :form   (walk-form (cadr form) parent env)
       :source form
       :parent parent))

(defwalker-handler untrans (form parent env)
  (unless (= 2 (length form))
    (error "Invalid UNTRANS form ~A" form))
  (new 'untrans-form
       :form   (walk-form (cadr form) parent env)
       :source form
       :parent parent))

(defunwalker-handler trans-form (form)
  `(trans ,(unwalk-form form)))

(defunwalker-handler untrans-form (form)
  `(untrans ,(unwalk-form form)))

Utilities 

(defun stms (forms)
  (mapcar #'stm forms))

(defun unstms (forms)
  (mapcar #'unstm forms))

(defun stmb (binds)
  (mapcar (lambda (bind)
            (cons (car bind)
                  (stm (cdr bind))))
          binds))

(defun unstmb (binds)
  (mapcar (lambda (bind)
            (cons (car bind)
                  (unstm (cdr bind))))
          binds))

(defgeneric trans-form (form)
  (:method ((form form))
    (new 'trans-form :form form))
  (:method ((form untrans-form))
    (form form)))

(defgeneric untrans-form (form)
  (:method ((form form))
    (new 'untrans-form :form form))
  (:method ((form trans-form))
    (form form)))

STM Walker 

(defstm-walker untrans-form (form)
  form)

(defstm-walker constant-form ()
  (trans-form *form*))

(defstm-walker variable-reference ()
  (trans-form *form*))

(defstm-walker if-form (consequent then else)
  (trans-form
   (new 'if-form
        :consequent (unstm (stm consequent))
        :then       (unstm (stm then))
        :else       (unstm (stm else)))))

(defstm-walker progn-form (body)
  (if (null (cdr body))
      (trans-form (unstm (stm (car body))))
      (trans-form
       (new 'progn-form
            :body (unstms (stms body))))))

(defstm-walker progv-form (vars-form values-form body)
  (trans-form
   (new 'progv-form
        :vars-form   (unstm  (stm  vars-form))
        :values-form (unstm  (stm  values-form))
        :body        (unstms (stms body)))))

(defstm-walker variable-binding-form (binds body)
  (trans-form
   (new (class-name-of *form*)
        :binds (unstmb (stmb binds))
        :body  (unstms (stms body)))))

(defstm-walker labels-form (binds body)
  (with-trans-funs (mapcar #'car binds)
    (trans-form
     (new 'labels-form
          :binds (unstmb (stmb binds))
          :body  (unstms (stms body))))))

(defstm-walker flet-form (binds body)
  (trans-form
   (new 'flet-form
        :binds (unstmb (stmb binds))
        :body
        (with-trans-funs (mapcar #'car binds)
          (unstms (stms body))))))

(defstm-walker lambda-function-form (arguments body)
  (trans-form
   (new 'lambda-function-form
        :arguments arguments
        :body      (list (stm (new 'progn-form :body body))))))

(defstm-walker setq-form (var value)
  (trans-form
   (new 'setq-form
        :var   var
        :value (unstm (stm value)))))

(defstm-walker application-form (operator arguments)
  (funcall (if (member operator *trans-funs*)
               #'identity
               #'trans-form)
           (new 'free-application-form
                :operator  operator
                :arguments (unstms (stms arguments)))))

(defstm-walker function-object-form ()
  (trans-form *form*))

(defstm-walker lambda-application-form (operator arguments)
  (trans-form
   (new 'lambda-application-form
        :operator  (unstm  (stm  operator))
        :arguments (unstms (stms arguments)))))

(defstm-walker multiple-value-call-form (func arguments)
  (funcall (cond ((and (typep func 'free-function-object-form)
                       (member (name func) *trans-funs*))
                  #'identity)
                 ((and (typep func 'constant-form)
                       (member (value func) *trans-funs*))
                  #'identity)
                 (t #'trans-form))
           (new 'multiple-value-call-form
                :func      (unstm  (stm  func))
                :arguments (unstms (stms arguments)))))

(defstm-walker multiple-value-prog1-form (first-form other-forms)
  (trans-form
   (new 'multiple-value-prog1-form
        :first-form  (unstm  (stm  first-form))
        :other-forms (unstms (stms other-forms)))))

(defstm-walker block-form (name body)
  (trans-form
   (new 'block-form
        :name name
        :body (unstms (stms body)))))

(defstm-walker return-from-form (target-block result)
  (trans-form
   (new 'return-from-form
        :target-block target-block
        :result       (unstm (stm result)))))

(defstm-walker catch-form (tag body)
  (trans-form
   (new 'catch-form
        :tag  (unstm  (stm  tag))
        :body (unstms (stms body)))))

(defstm-walker throw-form (tag value)
  (trans-form
   (new 'throw-form
        :tag   (unstm (stm tag))
        :value (unstm (stm value)))))

(defstm-walker tagbody-form (body)
  (trans-form
   (new 'tagbody-form
        :body (unstms (stms body)))))

(defstm-walker go-tag-form ()
  (trans-form *form*))

(defstm-walker go-form ()
  (trans-form *form*))

(defstm-walker unwind-protect-form (protected-form cleanup-form)
  (trans-form
   (new 'unwind-protect-form
        :protected-form (unstm  (stm  protected-form))
        :cleanup-form   (unstms (stms cleanup-form)))))

(defstm-walker the-form (type-form value)
  (trans-form
   (new 'the-form
        :type-form type-form
        :value     (unstm (stm value)))))

(defstm-walker eval-when-form (eval-when-times body)
  (trans-form
   (new 'eval-when-form
        :eval-when-times eval-when-times
        :body            (unstms (stms body)))))

UNSTM Walker 

(defunstm-walker form ()
  *form*)

(defunstm-walker trans-form (form)
  form)

(defunstm-walker free-application-form (operator)
  (if (member operator *trans-funs*)
      (untrans-form *form*)
      *form*))