X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwarm-mswin.lisp;h=5a973ff7dad1370029116e90293a95160b1cd1d5;hb=6129b1ebc5125c57d6446c061155f5f653f41725;hp=eef4e56e7220f1aa427044d7fedef9bffc8c2b93;hpb=ed1910efb36f71b5ebe33b5ffffd7195e15644de;p=sbcl.git

diff --git a/src/code/warm-mswin.lisp b/src/code/warm-mswin.lisp
index eef4e56..5a973ff 100644
--- a/src/code/warm-mswin.lisp
+++ b/src/code/warm-mswin.lisp
@@ -104,3 +104,65 @@
                               (if got code -1))))
                     child))
               -2))))))
+
+(define-alien-routine ("SetConsoleCtrlHandler" set-console-ctrl-handler) int
+  (callback (function (:stdcall int) int))
+  (enable int))
+
+(defun windows-console-control-handler (event-code)
+  (case event-code
+    (0
+     (flet ((interrupt-it ()
+              (let* ((context
+                       (sb-di::nth-interrupt-context
+                        (1- sb-kernel:*free-interrupt-context-index*)))
+                     (pc (sb-vm:context-pc context)))
+                (with-interrupts
+                  (let ((int (make-condition
+                              'interactive-interrupt
+                              :context context
+                              :address (sb-sys:sap-int pc))))
+                    ;; First SIGNAL, so that handlers can run.
+                    (signal int)
+                    (%break 'sigint int))))))
+       (sb-thread:interrupt-thread (sb-thread::foreground-thread)
+                                   #'interrupt-it)
+       t))))
+
+(defvar *console-control-handler* #'windows-console-control-handler)
+(defvar *console-control-enabled* nil)
+(defvar *console-control-spec* nil)
+
+(sb-alien::define-alien-callback *alien-console-control-handler* (:stdcall int)
+    ((event-code int))
+  (if (ignore-errors (funcall *console-control-handler* event-code)) 1 0))
+
+(defun console-control-handler ()
+  "Get or set windows console control handler.
+
+Boolean value: use default handler (NIL) or ignore event (T).  Symbol
+or function: designator for a function that receives an event code and
+returns generalized boolean (false to fall back to other handlers,
+true to stop searching)." *console-control-spec*)
+
+(defun (setf console-control-handler) (new-handler)
+  (etypecase new-handler
+    (boolean
+     (aver (plusp (set-console-ctrl-handler
+                   (sap-alien (int-sap 0)
+                              (function (:stdcall int) int))
+                   (if new-handler 1 0))))
+     (setf *console-control-enabled* nil))
+    ((or symbol function)
+     (setf *console-control-handler* new-handler)
+     (aver (plusp (set-console-ctrl-handler *alien-console-control-handler* 1)))))
+  (setf *console-control-spec* new-handler))
+
+(defun initialize-console-control-handler (&optional reset-to-default-p)
+  (setf (console-control-handler)
+        (if reset-to-default-p
+            'windows-console-control-handler
+            (console-control-handler))))
+
+(initialize-console-control-handler t)
+(pushnew 'initialize-console-control-handler sb-ext:*init-hooks*)