[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Thu Oct 21 08:06:55 UTC 2010
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv18684
Modified Files:
ChangeLog swank-abcl.lisp
Log Message:
Require ABCL 0.22 and remove obsolete conditionalisation.
* swank-abcl.lisp (call-with-debugger-hook)
(install-debugger-globally)
(call-with-debugging-environment, backtrace, print-frame, spawn):
Remove #+/#- stuff.
(preferred-communication-style): Return :spawn unconditionally.
(sys::break): Removed.
--- /project/slime/cvsroot/slime/ChangeLog 2010/10/20 11:42:19 1.2156
+++ /project/slime/cvsroot/slime/ChangeLog 2010/10/21 08:06:55 1.2157
@@ -1,3 +1,14 @@
+2010-10-21 Helmut Eller <heller at common-lisp.net>
+
+ Require ABCL 0.22 and remove obsolete conditionalisation.
+
+ * swank-abcl.lisp (call-with-debugger-hook)
+ (install-debugger-globally)
+ (call-with-debugging-environment, backtrace, print-frame, spawn):
+ Remove #+/#- stuff.
+ (preferred-communication-style): Return :spawn unconditionally.
+ (sys::break): Removed.
+
2010-10-20 Stas Boukarev <stassats at gmail.com>
* slime.el (slime-connect): Convert the port number read from
--- /project/slime/cvsroot/slime/swank-abcl.lisp 2010/03/04 13:22:29 1.83
+++ /project/slime/cvsroot/slime/swank-abcl.lisp 2010/10/21 08:06:55 1.84
@@ -12,25 +12,10 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :collect) ;just so that it doesn't spoil the flying letters
- (require :pprint))
-
-;;; The introduction of SYS::*INVOKE-DEBUGGER-HOOK* obliterates the
-;;; need for redefining BREAK. The following should thus be removed at
-;;; some point in the future.
-#-#.(swank-backend:with-symbol '*invoke-debugger-hook* 'sys)
-(defun sys::break (&optional (format-control "BREAK called")
- &rest format-arguments)
- (let ((sys::*saved-backtrace*
- #+#.(swank-backend:with-symbol 'backtrace 'sys)
- (sys:backtrace)
- #-#.(swank-backend:with-symbol 'backtrace 'sys)
- (ext:backtrace-as-list)))
- (with-simple-restart (continue "Return from BREAK.")
- (invoke-debugger
- (sys::%make-condition 'simple-condition
- (list :format-control format-control
- :format-arguments format-arguments))))
- nil))
+ (require :pprint)
+ (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4))
+ 0.22)
+ () "This file needs ABCL version 0.22 or newer"))
(defimplementation make-output-stream (write-string)
(ext:make-slime-output-stream write-string))
@@ -144,11 +129,7 @@
(defimplementation preferred-communication-style ()
-#+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
- :spawn
-#-#.(cl:if (cl:find-package :threads) '(:and) '(:or))
- nil
-)
+ :spawn)
(defimplementation create-socket (host port)
(ext:make-server-socket port))
@@ -266,7 +247,6 @@
(doc 'class)))
result)))
-
(defimplementation describe-definition (symbol namespace)
(ecase namespace
(:variable
@@ -285,29 +265,27 @@
(:class
(describe (find-class symbol)))))
-
+
;;;; Debugger
-;;; Copied from swank-sbcl.lisp.
+;; Copied from swank-sbcl.lisp.
+;;
+;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*,
+;; so we have to make sure that the latter gets run when it was
+;; established locally by a user (i.e. changed meanwhile.)
(defun make-invoke-debugger-hook (hook)
- #'(lambda (condition old-hook)
- ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
- ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
- ;; run when it was established locally by a user (i.e. changed
- ;; meanwhile.)
- (if *debugger-hook*
- (funcall *debugger-hook* condition old-hook)
- (funcall hook condition old-hook))))
+ (lambda (condition old-hook)
+ (if *debugger-hook*
+ (funcall *debugger-hook* condition old-hook)
+ (funcall hook condition old-hook))))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
- #+#.(swank-backend:with-symbol '*invoke-debugger-hook* 'sys)
(sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
(funcall fun)))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
- #+#.(swank-backend:with-symbol '*invoke-debugger-hook* 'sys)
(setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
(defvar *sldb-topframe*)
@@ -315,25 +293,14 @@
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
(*sldb-topframe*
- #+#.(swank-backend:with-symbol 'backtrace 'sys)
(second (member magic-token (sys:backtrace)
- :key #'(lambda (frame)
- (first (sys:frame-to-list frame)))))
- #-#.(swank-backend:with-symbol 'backtrace 'sys)
- (second (member magic-token (ext:backtrace-as-list)
- :key #'(lambda (frame)
- (first frame))))
- ))
+ :key (lambda (frame)
+ (first (sys:frame-to-list frame)))))))
(funcall debugger-loop-fn)))
(defun backtrace (start end)
"A backtrace without initial SWANK frames."
- (let ((backtrace
- #+#.(swank-backend:with-symbol 'backtrace 'sys)
- (sys:backtrace)
- #-#.(swank-backend:with-symbol 'backtrace 'sys)
- (ext:backtrace-as-list)
- ))
+ (let ((backtrace (sys:backtrace)))
(subseq (or (member *sldb-topframe* backtrace) backtrace)
start end)))
@@ -345,12 +312,8 @@
(backtrace start end)))
(defimplementation print-frame (frame stream)
- (write-string
- #+#.(swank-backend:with-symbol 'backtrace 'sys)
- (sys:frame-to-string frame)
- #-#.(swank-backend:with-symbol 'backtrace 'sys)
- (string-trim '(#\space #\newline) (prin1-to-string frame))
- stream))
+ (write-string (sys:frame-to-string frame)
+ stream))
(defimplementation frame-locals (index)
`(,(list :name "??" :id 0 :value "??")))
@@ -577,85 +540,83 @@
;;;; Multithreading
-#+#.(cl:if (cl:find-package :threads) '(:and) '(:or))
-(progn
- (defimplementation spawn (fn &key name)
- (threads:make-thread (lambda () (funcall fn)) :name name))
-
- (defvar *thread-plists* (make-hash-table) ; should be a weak table
- "A hashtable mapping threads to a plist.")
-
- (defvar *thread-id-counter* 0)
-
- (defimplementation thread-id (thread)
- (threads:synchronized-on *thread-plists*
- (or (getf (gethash thread *thread-plists*) 'id)
- (setf (getf (gethash thread *thread-plists*) 'id)
+(defimplementation spawn (fn &key name)
+ (threads:make-thread (lambda () (funcall fn)) :name name))
+
+(defvar *thread-plists* (make-hash-table) ; should be a weak table
+ "A hashtable mapping threads to a plist.")
+
+(defvar *thread-id-counter* 0)
+
+(defimplementation thread-id (thread)
+ (threads:synchronized-on *thread-plists*
+ (or (getf (gethash thread *thread-plists*) 'id)
+ (setf (getf (gethash thread *thread-plists*) 'id)
(incf *thread-id-counter*)))))
- (defimplementation find-thread (id)
- (find id (all-threads)
+(defimplementation find-thread (id)
+ (find id (all-threads)
:key (lambda (thread)
- (getf (gethash thread *thread-plists*) 'id))))
+ (getf (gethash thread *thread-plists*) 'id))))
- (defimplementation thread-name (thread)
- (threads:thread-name thread))
+(defimplementation thread-name (thread)
+ (threads:thread-name thread))
- (defimplementation thread-status (thread)
- (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
+(defimplementation thread-status (thread)
+ (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
- (defimplementation make-lock (&key name)
- (declare (ignore name))
- (threads:make-thread-lock))
-
- (defimplementation call-with-lock-held (lock function)
- (threads:with-thread-lock (lock) (funcall function)))
-
- (defimplementation current-thread ()
- (threads:current-thread))
-
- (defimplementation all-threads ()
- (copy-list (threads:mapcar-threads #'identity)))
-
- (defimplementation thread-alive-p (thread)
- (member thread (all-threads)))
-
- (defimplementation interrupt-thread (thread fn)
- (threads:interrupt-thread thread fn))
-
- (defimplementation kill-thread (thread)
- (threads:destroy-thread thread))
-
- (defstruct mailbox
- (queue '()))
-
- (defun mailbox (thread)
- "Return THREAD's mailbox."
- (threads:synchronized-on *thread-plists*
- (or (getf (gethash thread *thread-plists*) 'mailbox)
- (setf (getf (gethash thread *thread-plists*) 'mailbox)
- (make-mailbox)))))
-
- (defimplementation send (thread message)
- (let ((mbox (mailbox thread)))
- (threads:synchronized-on mbox
- (setf (mailbox-queue mbox)
- (nconc (mailbox-queue mbox) (list message)))
- (threads:object-notify-all mbox))))
-
- (defimplementation receive-if (test &optional timeout)
- (let* ((mbox (mailbox (current-thread))))
- (assert (or (not timeout) (eq timeout t)))
- (loop
- (check-slime-interrupts)
- (threads:synchronized-on mbox
- (let* ((q (mailbox-queue mbox))
- (tail (member-if test q)))
- (when tail
- (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
- (return (car tail)))
+(defimplementation make-lock (&key name)
+ (declare (ignore name))
+ (threads:make-thread-lock))
+
+(defimplementation call-with-lock-held (lock function)
+ (threads:with-thread-lock (lock) (funcall function)))
+
+(defimplementation current-thread ()
+ (threads:current-thread))
+
+(defimplementation all-threads ()
+ (copy-list (threads:mapcar-threads #'identity)))
+
+(defimplementation thread-alive-p (thread)
+ (member thread (all-threads)))
+
+(defimplementation interrupt-thread (thread fn)
+ (threads:interrupt-thread thread fn))
+
+(defimplementation kill-thread (thread)
+ (threads:destroy-thread thread))
+
+(defstruct mailbox
+ (queue '()))
+
+(defun mailbox (thread)
+ "Return THREAD's mailbox."
+ (threads:synchronized-on *thread-plists*
+ (or (getf (gethash thread *thread-plists*) 'mailbox)
+ (setf (getf (gethash thread *thread-plists*) 'mailbox)
+ (make-mailbox)))))
+
+(defimplementation send (thread message)
+ (let ((mbox (mailbox thread)))
+ (threads:synchronized-on mbox
+ (setf (mailbox-queue mbox)
+ (nconc (mailbox-queue mbox) (list message)))
+ (threads:object-notify-all mbox))))
+
+(defimplementation receive-if (test &optional timeout)
+ (let* ((mbox (mailbox (current-thread))))
+ (assert (or (not timeout) (eq timeout t)))
+ (loop
+ (check-slime-interrupts)
+ (threads:synchronized-on mbox
+ (let* ((q (mailbox-queue mbox))
+ (tail (member-if test q)))
+ (when tail
+ (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
+ (return (car tail)))
(when (eq timeout t) (return (values nil t)))
- (threads:object-wait mbox 0.3)))))))
+ (threads:object-wait mbox 0.3))))))
(defimplementation quit-lisp ()
(ext:exit))
More information about the slime-cvs
mailing list