[slime-cvs] CVS slime

[heller]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv20668

Modified Files:
	ChangeLog swank-lispworks.lisp 
Log Message:
* swank-lispworks.lisp (defimplementation): Record location.

--- /project/slime/cvsroot/slime/ChangeLog	2008/08/09 19:57:12	1.1424
+++ /project/slime/cvsroot/slime/ChangeLog	2008/08/09 19:57:17	1.1425
@@ -18,6 +18,10 @@
 
 2008-08-09  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-lispworks.lisp (defimplementation): Record location.
+
+2008-08-09  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (*maximum-pipelined-output-chunks*): New variable
 
 2008-08-09  Helmut Eller  <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/08/09 19:57:00	1.110
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/08/09 19:57:17	1.111
@@ -32,9 +32,15 @@
 (defun swank-mop:eql-specializer-object (eql-spec)
   (second eql-spec))
 
-(when (fboundp 'dspec::define-dspec-alias)
-  (dspec::define-dspec-alias defimplementation (name args &rest body)
-    `(defun ,name ,args , at body)))
+(eval-when (:compile-toplevel :execute :load-toplevel)
+  (defvar *original-defimplementation* (macro-function 'defimplementation))
+  (defmacro defimplementation (&whole whole name args &body body 
+                               &environment env)
+    (declare (ignore args body))
+    `(progn
+       (dspec:record-definition '(defun ,name) (dspec:location)
+                                :check-redefinition-p nil)
+       ,(funcall *original-defimplementation* whole env))))
 
 ;;; TCP server
 
@@ -212,14 +218,19 @@
                  :io-bindings io-bindings
                  :debugger-hoook hook))
 
-(defmethod env-internals:environment-display-notifier
+(defmethod env-internals:environment-display-notifier 
     ((env slime-env) &key restarts condition)
-  (declare (ignore restarts))
-  (funcall (slot-value env 'debugger-hook) condition *debugger-hook*))
+  (declare (ignore restarts condition))
+  ;;(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
+  (values t nil)
+  )
 
 (defmethod env-internals:environment-display-debugger ((env slime-env))
   *debug-io*)
 
+(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
+  (apply (swank-sym :y-or-n-p-in-emacs) msg args))
+
 (defimplementation call-with-debugger-hook (hook fun)
   (let ((*debugger-hook* hook))
     (env:with-environment ((slime-env hook '()))
@@ -229,19 +240,6 @@
   (setq *debugger-hook* function)
   (setf (env:environment) (slime-env function '())))
 
-(defmethod env-internals:environment-display-notifier 
-    ((env slime-env) &key restarts condition)
-  (declare (ignore restarts))
-  ;;(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
-  (values t nil)
-  )
-
-(defmethod env-internals:environment-display-debugger ((env slime-env))
-  *debug-io*)
-
-(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
-  (apply (swank-sym :y-or-n-p-in-emacs) msg args))
-
 (defvar *sldb-top-frame*)
 
 (defun interesting-frame-p (frame)