From 168a6cebcd3c1922cf23d59f8c22cb260074d524 Mon Sep 17 00:00:00 2001 From: pw <pw> Date: Wed, 7 Jan 1998 12:18:58 +0000 Subject: [PATCH] From Timothy Miller: I've been plagued by intermittent timing-related bugs in the motif code that I think I have finally tracked down: when the lisp end waits for a :confirm reply to a call it's made to the server, it doesn't correctly handle getting translations, callbacks, actions, etc. while waiting. This patch fixes that. Tim --- motif/lisp/interface-glue.lisp | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/motif/lisp/interface-glue.lisp b/motif/lisp/interface-glue.lisp index 9d0b59d48..94ff95165 100644 --- a/motif/lisp/interface-glue.lisp +++ b/motif/lisp/interface-glue.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/lisp/interface-glue.lisp,v 1.4 1997/01/18 14:31:44 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/motif/lisp/interface-glue.lisp,v 1.5 1998/01/07 12:18:58 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -29,16 +29,22 @@ (let ((reply (dispatch-server-reply fd))) (when reply (return reply))))) +;;; From Timothy Miller, Jan-98 -- +;;; wait-for-server-reply is only ever called (currently) when waiting for a +;;;:confirm reply, and is currently the only place that cares about the return +;;;value from this function. Hence, we make the return value for everything else +;;;nil to avoid mysterious timing problems with actions or whatever getting +;;;called while lisp is trying to execute requests. (defun dispatch-server-reply (fd) (let* ((reply (receive-message fd)) (kind (svref reply-table (xti::message-get-dblword reply)))) (case kind ((:confirm :values) reply) - (:callback (handle-callback reply)) - (:protocol (handle-protocol reply)) - (:action (handle-action reply)) - (:event (handle-event reply)) + (:callback (handle-callback reply) nil) + (:protocol (handle-protocol reply) nil) + (:action (handle-action reply) nil) + (:event (handle-event reply) nil) (:error (let ((errmsg (toolkit-read-value reply))) (destroy-message reply) -- GitLab