tests/compare-and-swap.impure.lisp

   1 ;;; Basics
   2
   3 (defstruct xxx yyy)
   4
   5 (macrolet ((test (init op)
   6              `(let ((x ,init)
   7                     (y (list 'foo))
   8                     (z (list 'bar)))
   9                 (assert (eql nil (compare-and-swap (,op x) nil y)))
  10                 (assert (eql y (compare-and-swap (,op x) nil z)))
  11                 (assert (eql y (,op x)))
  12                 (let ((x "foo"))
  13                   (multiple-value-bind (res err)
  14                      (ignore-errors (compare-and-swap (,op x) nil nil))
  15                     (assert (not res))
  16                     (assert (typep err 'type-error)))))))
  17   (test (cons nil :no) car)
  18   (test (cons nil :no) first)
  19   (test (cons :no nil) cdr)
  20   (test (cons :no nil) rest)
  21   (test '.foo. symbol-plist)
  22   (test (progn (set '.bar. nil) '.bar.) symbol-value)
  23   (test (make-xxx) xxx-yyy))
  24
  25 (defvar *foo*)
  26
  27 ;;; thread-local bindings
  28
  29 (let ((*foo* 42))
  30   (let ((*foo* nil))
  31     (assert (eql nil (compare-and-swap (symbol-value '*foo*) nil t)))
  32     (assert (eql t (compare-and-swap (symbol-value '*foo*) nil :foo)))
  33     (assert (eql t *foo*)))
  34   (assert (eql 42 *foo*)))
  35
  36 ;;; unbound symbols + symbol-value
  37
  38 (assert (not (boundp '*foo*)))
  39
  40 (multiple-value-bind (res err)
  41     (ignore-errors (compare-and-swap (symbol-value '*foo*) nil t))
  42   (assert (not res))
  43   (assert (typep err 'unbound-variable)))
  44
  45 (defvar *bar* t)
  46
  47 (let ((*bar* nil))
  48    (makunbound '*bar*)
  49    (multiple-value-bind (res err)
  50        (ignore-errors (compare-and-swap (symbol-value '*bar*) nil t))
  51      (assert (not res))
  52      (assert (typep err 'unbound-variable))))
  53
  54 ;;; SVREF
  55
  56 (defvar *v* (vector 1))
  57
  58 ;; basics
  59 (assert (eql 1 (compare-and-swap (svref *v* 0) 1 2)))
  60 (assert (eql 2 (compare-and-swap (svref *v* 0) 1 3)))
  61 (assert (eql 2 (svref *v* 0)))
  62
  63 ;; bounds
  64 (multiple-value-bind (res err)
  65     (ignore-errors (compare-and-swap (svref *v* -1) 1 2))
  66   (assert (not res))
  67   (assert (typep err 'type-error)))
  68 (multiple-value-bind (res err)
  69     (ignore-errors (compare-and-swap (svref *v* 1) 1 2))
  70   (assert (not res))
  71   (assert (typep err 'type-error)))
  72
  73 ;; type of the first argument
  74 (multiple-value-bind (res err)
  75     (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
  76     (assert (not res))
  77     (assert (typep err 'type-error)))