Skip to content

Instantly share code, notes, and snippets.

@edw
Last active May 19, 2020 16:31
Show Gist options
  • Save edw/cd6ad639d3fc294ab808eb5bb7782a81 to your computer and use it in GitHub Desktop.
Save edw/cd6ad639d3fc294ab808eb5bb7782a81 to your computer and use it in GitHub Desktop.
Scheme implementation of Clojure style atoms
(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))))
(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))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment