with-input-context: rewrite the macro to use a trampoline

Previously the macro open-coded the behavior, while now we have it trampoline to
INVOKE-WITH-INPUT-CONTEXT.

Moreover we remove the call to HIGHLIGHT-CURRENT-PRESENTATION -- it is misguided
because the input context may change multiple times before we return the control
to the event loop, and that leads to excessive computations.

1 files changed, 33 insertions, 27 deletions

diff --git a/Core/clim-core/presentations/typed-input.lisp b/Core/clim-core/presentations/typed-input.lisp
index 973b7498..3b8db76e 100644
--- a/Core/clim-core/presentations/typed-input.lisp
+++ b/Core/clim-core/presentations/typed-input.lisp
@@ -37,7 +37,7 @@
       (output-recording-stream-p (event-sheet gesture)))))
 
 (defun input-context-event-handler (stream)
-  (highlight-applicable-presentation *application-frame* stream *input-context*))
+  (highlight-current-presentation *application-frame* *input-context*))
 
 (defun input-context-button-press-handler (stream button-event)
   (declare (ignore stream))
@@ -45,40 +45,46 @@
                                             (event-sheet button-event)
                                             button-event))
 
-;;; FIXME rewrite as a trampoline to INVOKE-WITH-INPUT-CONTEXT. -- jd 2024-08-25
+(defun invoke-with-input-context (form-cont case-cont type &key override)
+  (let* ((expanded-type (expand-presentation-type-abbreviation type))
+         (*input-context*
+           (list* (cons expanded-type case-cont)
+                  (if override nil *input-context*)))
+         (*pointer-button-press-handler* #'input-context-button-press-handler)
+         (*input-wait-test* #'input-context-wait-test)
+         (*input-wait-handler* #'input-context-event-handler))
+    (funcall form-cont)))
+
 (defmacro with-input-context
-    ((type &key override)
-     (&optional object-var type-var event-var options-var)
+    ((type &rest args &key override)
+     (&optional (object-var  (gensym "OBJECT"))
+                (type-var    (gensym "TYPE"))
+                (event-var   (gensym "EVENT"))
+                (options-var (gensym "OPTIONS")))
      form
      &body pointer-cases)
+  (declare (ignore override))
   (let ((vars `(,(or object-var (gensym "OBJECT"))
                 ,(or type-var (gensym "TYPE"))
                 ,(or event-var (gensym "EVENT"))
                 ,(or options-var (gensym "OPTIONS"))))
-        (return-block (gensym "RETURN-BLOCK"))
+        (case-cont (gensym "POINTER-CASES"))
+        (form-cont (gensym "CONTINUATION"))
         (context-block (gensym "CONTEXT-BLOCK")))
-    `(block ,return-block
-       (multiple-value-bind ,vars
-           (block ,context-block
-             (let ((*input-context*
-                     (cons (cons (expand-presentation-type-abbreviation ,type)
-                                 #'(lambda (object type event options)
-                                     (return-from ,context-block
-                                       (values object type event options))))
-                           ,(if override nil '*input-context*)))
-                   (*pointer-button-press-handler*
-                     #'input-context-button-press-handler)
-                   (*input-wait-test* #'input-context-wait-test)
-                   (*input-wait-handler* #'input-context-event-handler))
-               (highlight-current-presentation *application-frame* *input-context*)
-               (return-from ,return-block ,form)))
-         (declare (ignorable ,@vars))
-         (cond ,@(mapcar #'(lambda (pointer-case)
-                             (destructuring-bind (case-type &body case-body)
-                                 pointer-case
-                               `((presentation-subtypep ,type-var ',case-type)
-                                 ,@case-body)))
-                         pointer-cases))))))
+    `(block ,context-block
+       (flet ((,case-cont ,vars
+                (declare (ignorable ,@vars))
+                (return-from ,context-block
+                  (cond ,@(mapcar #'(lambda (pointer-case)
+                                      (destructuring-bind (case-type &body case-body)
+                                          pointer-case
+                                        `((presentation-subtypep ,type-var ',case-type)
+                                          ,@case-body)))
+                                  pointer-cases))))
+              (,form-cont () ,form))
+         (invoke-with-input-context (function ,form-cont)
+                                    (function ,case-cont)
+                                    ,type ,@args)))))
 
 (define-presentation-generic-function %presentation-default-processor
     presentation-default-processor