[slime-cvs] CVS update: slime/swank-lispworks.lisp

[Helmut Eller]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv16274

Modified Files:
	swank-lispworks.lisp 
Log Message:
(make-sigint-handler): New function.
(emacs-connected): Use it.
Date: Wed Jan 21 17:35:38 2004
Author: heller

Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.17 slime/swank-lispworks.lisp:1.18
--- slime/swank-lispworks.lisp:1.17	Mon Jan 19 15:14:35 2004
+++ slime/swank-lispworks.lisp	Wed Jan 21 17:35:38 2004
@@ -7,7 +7,7 @@
 ;;; This code has been placed in the Public Domain.  All warranties
 ;;; are disclaimed.
 ;;;
-;;;   $Id: swank-lispworks.lisp,v 1.17 2004/01/19 20:14:35 lgorrie Exp $
+;;;   $Id: swank-lispworks.lisp,v 1.18 2004/01/21 22:35:38 heller Exp $
 ;;;
 
 (in-package :swank)
@@ -29,6 +29,8 @@
 
 ;;; TCP server
 
+(setq *swank-in-background* :spawn)
+
 (defun socket-fd (socket)
   (etypecase socket
     (fixnum socket)
@@ -56,27 +58,27 @@
     (make-instance 'comm:socket-stream :socket fd :direction :io 
                    :element-type 'base-char)))
 
-(defimplementation spawn (fn &key name)
-  (mp:process-run-function name () fn))
-
 (defimplementation emacs-connected ()
   ;; Set SIGINT handler on Swank request handler thread.
-  (sys:set-signal-handler +sigint+ #'sigint-handler))
+  (sys:set-signal-handler +sigint+ (make-sigint-handler mp:*current-process*)))
 
 ;;; Unix signals
 
-(defun sigint-handler (&rest args)
-  (declare (ignore args))
+(defun sigint-handler ()
   (with-simple-restart  (continue "Continue from SIGINT handler.")
     (invoke-debugger "SIGINT")))
 
+(defun make-sigint-handler (process)
+  (lambda (&rest args)
+    (declare (ignore args))
+    (mp:process-interrupt process #'sigint-handler)))
+
 (defmethod call-without-interrupts (fn)
   (lispworks:without-interrupts (funcall fn)))
 
 (defmethod getpid ()
   (system::getpid))
 
-
 (defimplementation arglist-string (fname)
   (format-arglist fname #'lw:function-lambda-list))
 
@@ -214,7 +216,8 @@
 	  (declare (ignore with))
 	  (loop for (name value symbol location) in vars
 		collect (list :name (to-string symbol) :id 0
-			      :value-string (princ-to-string value)))))))
+			      :value-string 
+                              (to-string value)))))))
 
 (defimplementation frame-catch-tags (index)
   (declare (ignore index))
@@ -227,6 +230,8 @@
 	  (if func 
 	      (dspec-source-location func))))))
 
+;;; Definition finding
+
 (defun dspec-source-location (dspec)
   (destructuring-bind (first) (dspec-source-locations dspec)
     first))
@@ -242,6 +247,8 @@
 (defimplementation find-function-locations (fname)
   (dspec-source-locations (from-string fname)))
 
+;;; Compilation 
+
 (defimplementation compile-file-for-emacs (filename load-p)
   (let ((compiler::*error-database* '()))
     (with-compilation-unit ()
@@ -281,6 +288,17 @@
              (delete-file binary-filename))))
     (delete-file filename)))
 
+
+;; (dspec:dspec-primary-name '(:top-level-form 19))
+
+(defun dspec-buffer-buffer-position (dspec)
+  (etypecase dspec
+    (cons (ecase (car dspec)
+            (defun `(:function-name ,(symbol-name (cadr dspec))))
+            ;; XXX this isn't quite right
+            (lw:top-level-form `(:source-path ,(cdr dspec) nil))))
+    (symbol `(:function-name ,(symbol-name dspec)))))
+
 (defun make-dspec-location (dspec location &optional tmpfile buffer position)
   (flet ((from-buffer-p () 
            (and (pathnamep location) tmpfile 
@@ -295,19 +313,19 @@
          (function-name (dspec)
            (etypecase dspec
              (symbol (symbol-name dspec))
-             (cons (symbol-name (dspec:dspec-primary-name dspec))))))
+             (cons (string (dspec:dspec-primary-name dspec))))))
     (cond ((from-buffer-p)
            (make-location `(:buffer ,buffer) `(:position ,position)))
           (t
            (etypecase location
              ((or pathname string) 
               (make-location `(:file ,(filename location))
-                             `(:function-name ,(function-name dspec))))
+                             (dspec-buffer-buffer-position dspec)))
              ((member :listener)
               `(:error ,(format nil "Function defined in listener: ~S" dspec)))
              ((member :unknown)
               `(:error ,(format nil "Function location unkown: ~S" dspec))))
-           )))) 
+           ))))
 
 (defun signal-error-data-base (database &optional tmpfile buffer position)
   (map-error-database 
@@ -376,22 +394,22 @@
 
 ;;; Multithreading
 
-(defmethod startup-multiprocessing ()
+(defimplementation startup-multiprocessing ()
   (mp:initialize-multiprocessing))
 
-(defmethod spawn (fn &key name)
+(defimplementation spawn (fn &key name)
   (mp:process-run-function name () fn))
 
-;; XXX: shurtcut
-(defmethod thread-id ()
+;; XXX: shortcut
+(defimplementation thread-id ()
   (mp:process-name mp:*current-process*))
 
-(defmethod thread-name (thread-id)
+(defimplementation thread-name (thread-id)
   thread-id)
 
-(defmethod make-lock (&key name)
+(defimplementation make-lock (&key name)
   (mp:make-lock :name name))
 
-(defmethod call-with-lock-held (lock function)
+(defimplementation call-with-lock-held (lock function)
   (mp:with-lock (lock) (funcall function)))