Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv25618

Modified Files: input.lisp Log Message:

In condition-wait, pass through return value of OpenMCL function.

Date: Fri Jul 1 14:59:39 2005 Author: tmoore

Index: mcclim/input.lisp diff -u mcclim/input.lisp:1.32 mcclim/input.lisp:1.33 --- mcclim/input.lisp:1.32 Sun Oct 31 02:46:31 2004 +++ mcclim/input.lisp Fri Jul 1 14:59:39 2005 @@ -228,33 +228,33 @@ (check-schedule eq) (let ((lock (event-queue-lock eq))) (with-lock-held (lock) - (with-slots (schedule-time) eq - (flet ((pred () - (not (null (event-queue-head eq))))) - (cond - (timeout - (loop as timeout-time = (+ now timeout) - with now = (now) - do (when (pred) - (return t)) - do (when (>= now timeout-time) - (return nil)) - do (let ((timeout (if schedule-time - (min (- schedule-time now) - (- timeout-time now)) - (- timeout-time now)))) - (condition-wait (event-queue-processes eq) - lock timeout)) - do (check-schedule eq))) - (schedule-time - (loop do (when (pred) - (return t)) - do (condition-wait - (event-queue-processes eq) lock (- schedule-time (now))) - do (check-schedule eq))) - (t - (or (pred) - (progn + (with-slots (schedule-time) eq + (flet ((pred () + (not (null (event-queue-head eq))))) + (cond + (timeout + (loop as timeout-time = (+ now timeout) + with now = (now) + do (when (pred) + (return t)) + do (when (>= now timeout-time) + (return nil)) + do (let ((timeout (if schedule-time + (min (- schedule-time now) + (- timeout-time now)) + (- timeout-time now)))) + (condition-wait (event-queue-processes eq) + lock timeout)) + do (check-schedule eq))) + (schedule-time + (loop do (when (pred) + (return t)) + do (condition-wait + (event-queue-processes eq) lock (- schedule-time (now))) + do (check-schedule eq))) + (t + (or (pred) + (progn (condition-wait (event-queue-processes eq) lock) t)))))))))