[Small-cl-src] simple locking retry

[Randall Randall]

Second try; let's see if I get it right this time:

This is intended to be a simple locking protocol for
systems that need to be usable on both serve-event-only
systems, like CMUCL on PPC, and more ordinary
multi-processing systems.  I'm currently using it as
part of PSILISP, my webapp framework.

This seems to work, and people I've run it by agree
that it seems to work, but there could be some serious
problem with it, so use at your own risk.  I am only
an egg.

This code is released as public domain.

(defmacro enqueue (queue)
   "Appends a unique ID to a queue."
   (let ((id (gensym)))
     `(let ((,id (gensym)))
        (setf ,queue (append ,queue (list ,id)))
        ,id)))

(defmacro lock (queue)
   "Waits in turn in the activity queue until all previous members have 
exited."
   (let ((id (gensym)))
     `(let* ((,id (enqueue ,queue)))
        #+(and acl-compat (not allegro) (not cmu))  ; CMUCL on PPC 
doesn't have MP, so we have to use serve-event
        (ACL-COMPAT.MP:process-wait "waiting for lock" #'eq ,id (car 
,queue))
        #+allegro
        (MP:process-wait "waiting for lock" #'eq ,id (car ,queue))
        #+cmu
        (do ()
            ((eq ,id (car ,queue)))
          (sys:serve-event 0))
        ,id)))

(defmacro unlock (queue)
   `(pop ,queue))

Use example, which assumes a WIDGET structure or class,
with a MYWIDGET instance, and a WIDGET-LOCK accessor.

(defmacro with-locked-widget ((lock-id-var queue) &body body)
   "Provides a method of locking a widget while in use, if everyone uses 
this."
   `(let ((,lock-id-var (lock ,queue)))
      (unwind-protect
       (progn , at body)
       (unlock ,queue))))

(with-locked-widget (l-id (widget-lock mywidget))
   ; do stuff
   )


--
Randall Randall <randall at randallsquared.com>
Property law should use #'EQ , not #'EQUAL .