Scheme implementation of Clojure style atoms

atomic-box-test.sld

(define-library (atomic-box-test)
  (import (scheme base) (scheme write) (chibi test) (atomic-box) (srfi 18))
  (export run-tests)
  (begin

    (define (thread-spawn thunk)
      (let ((t (make-thread thunk)))
        (thread-start! t)
        t))

    (define (run-tests)
      (test-begin "overlapping swaps")
      (let* ((b (boxa 42))
             (t1 (thread-spawn
                  (lambda ()
                    (swap-box-a! b (lambda (v)
                                     (display "in X")
                                     (thread-sleep! 0.5)
                                     (display "leaving X")
                                     (* v 10))))))
             (t2 (thread-spawn
                  (lambda ()
                    (swap-box-a! b (lambda (v)
                                     (display "in Y")
                                     (display "leaving Y")
                                     (+ v 1)))))))
        (thread-join! t1)
        (thread-join! t2)
        (test 430 (unboxa b)))
      (test-end))))

atomic-box.sld

(define-library (atomic-box)
  (import (scheme base) (srfi 9) (srfi 18) (srfi 111))
  (export boxa boxa? unboxa swap-box-a! set-box-a!)
  (begin

    (define-record-type <atomic-box>
      (atomic-box-ctor value mutex serial)
      boxa?
      (value atomic-box-value set-atomic-box-value!)
      (mutex atomic-box-mutex set-atomic-box-mutex!)
      (serial atomic-box-serial set-atomic-box-serial!))

    (define (boxa value)
      (let* ((mutex (make-mutex 'abox-mutex))
             (serial 0))
        (atomic-box-ctor value mutex serial)))

    (define (unboxa ab)
      (atomic-box-value ab))

    (define (swap-box-a! ab proc . additional-args)
      (let* ((mutex (atomic-box-mutex ab)))
        (let loop ()
          (mutex-lock! mutex)
          (let ((before-serial (atomic-box-serial ab))
                (before-value (atomic-box-value ab)))
            (mutex-unlock! mutex)
            (let ((after-value (apply proc before-value additional-args)))
              (mutex-lock! mutex)
              (let ((after-serial (atomic-box-serial ab)))
                (cond ((eq? before-serial after-serial)
                       (set-atomic-box-serial! ab (+ before-serial 1))
                       (set-atomic-box-value! ab after-value)
                       (mutex-unlock! mutex)
                       (begin))
                      (else
                       (mutex-unlock! mutex)
                       (loop)))))))))

    (define (set-box-a! ab new-value)
      (let* ((mutex (atomic-box-mutex ab)))
        (mutex-lock! mutex)
        (let ((before-serial (atomic-box-serial ab)))
          (set-atomic-box-serial! ab (+ before-serial 1))
          (set-atomic-box-value! ab new-value)
          (mutex-unlock! mutex)
          (begin))))))