with-read-lock.lisp

(defvar *locks* ())

(defmacro with-read (table index variable &body body)
  `(let ((,variable (gethash ,index ,table))
	 (old-locks *locks*)
	 (*locks* (list* (cons ,table ,index) *locks*)))
     (flet ((update (table index value)
	      (let ((*locks* old-locks))
		(%update table index value))))
       ,@body)))

(defun %update (table index value)
  (loop for (ltable . lindex) in *locks*
     if (and (eq ltable table) (equal index lindex))
     do (error "lock violation"))
  (setf (gethash index table) value))

(defun update (table index value)
  (%update table index value))

(defvar *table1* (make-hash-table))

(setf (gethash 0 *table1*) 5)

(defun test1 ()
  (with-read *table1* 0 x
    (princ x)))

(defun test2 ()
  (with-read *table1* 0 x
    (update *table1* 0 (+ 1 x))))

(defun test3 ()
  (test2) ; it's ok to call it outside of with-read
  (with-read *table1* 0 x
    (update *table1* 0 (+ 1 x))))

(defun test4 ()
  (with-read *table1* 0 x
    (princ x)
    (test2) ; results in lock violation
    (princ x)))