jdi@sparky.UUCP (John Irwin) (08/31/88)
Well, looks like I choked in the message where I sent out code to
allow Bill Janssen's CLX example to work correctly in Allegro CL.
Here is the revised code:
-- John Irwin, Franz Inc.
-------
from dependent.cl:
#+excl
;;
;; Note that there is a special hack here. If the current process is nil it
;; means we're running in the scheduler stack group, which means in turn that
;; we're running a process wait function. This wait functions should *always*
;; be: (event-listen display 0). So if we are running in the scheduler and the
;; lock isn't already being held just run the body without trying to grab the
;; lock. If the lock *is* already being held we have to throw out of the
;; event-listen.
;;
(defmacro holding-lock ((locator &optional whostate) &body body)
;; This macro is for use in a multi-process environment.
(let ((lock (gensym)) (curproc (gensym)) (locker (gensym))
(without-interrupts-state (gensym)))
`(let* ((,without-interrupts-state excl::*without-interrupts*)
(excl::*without-interrupts* t)
(,lock ,locator)
(,curproc mp:*current-process*) ; nil if in scheduler (wait fun)
(,locker (mp:process-lock-locker ,lock)))
(declare (special *inside-event-listen-catch*))
(unwind-protect
(progn
(if (and (null ,curproc) ,locker)
(if (and (boundp '*inside-event-listen-catch*)
*inside-event-listen-catch*)
(throw 'event-listen :would-block)
(error "The only CLX function call allowed from a process wait function is \
event-listen with timeout 0.")))
(excl:if* (eq ,locker ,curproc)
then
(setq ,locker nil)
else
(setq ,locker ,curproc)
(mp:process-lock ,lock ,curproc
,@(when whostate `(,whostate))))
(setq excl::*without-interrupts* ,without-interrupts-state)
,@body)
(if (and ,curproc (eq ,locker ,curproc))
(mp:process-unlock ,lock ,curproc))))))
from input.cl:
(defvar *inside-event-listen-catch* nil)
#+excl
(defun event-listen (display &optional (timeout 0))
(declare (type display display)
(type (or null number) timeout))
;; Returns the number of events queued locally, if any, else nil. Hangs
;; waiting for events, forever if timeout is nil, else for the specified
;; number of seconds. However, if we are running a process wait function
;; (in the scheduler stack group) and the input lock is held by another
;; process, return nil.
(let ((queue (or *recursive-event-queue*
(display-event-queue display)))
(*inside-event-listen-catch* t))
(if (cdr queue)
(length (cdr queue))
(unless (eq :would-block
(catch 'event-listen (wait-for-event display timeout nil)))
(and (cdr queue) (length (cdr queue)))))))