From sboukarev at common-lisp.net  Wed Aug  4 18:20:22 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 04 Aug 2010 14:20:22 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OgiZi-0000N9-F2@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv32156

Modified Files:
	ChangeLog slime.el swank.lisp 
Log Message:
* slime.el (slime-dispatch-event): :eval-no-wait, lisp sends a
form in a string, not a function name and arguments. Add
slime-check-eval-in-emacs-enabled.
* swank.lisp (defpackage): export eval-for-emacs.


--- /project/slime/cvsroot/slime/ChangeLog	2010/07/30 16:14:50	1.2117
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/04 18:20:22	1.2118
@@ -1,3 +1,10 @@
+2010-08-04  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-dispatch-event): :eval-no-wait, lisp sends a
+	form in a string, not a function name and arguments. Add
+	slime-check-eval-in-emacs-enabled.
+	* swank.lisp (defpackage): export eval-for-emacs.
+
 2010-07-30  Helmut Eller  <heller at common-lisp.net>
 
 	Don't get confused by END-OF-FILE on unrelated streams.
--- /project/slime/cvsroot/slime/slime.el	2010/07/30 16:14:50	1.1330
+++ /project/slime/cvsroot/slime/slime.el	2010/08/04 18:20:22	1.1331
@@ -2270,8 +2270,9 @@
            (setf (slime-lisp-features) features))
           ((:indentation-update info)
            (slime-handle-indentation-update info))
-          ((:eval-no-wait fun args)
-           (apply (intern fun) args))
+          ((:eval-no-wait form)
+           (slime-check-eval-in-emacs-enabled)
+           (eval (read form)))
           ((:eval thread tag form-string)
            (slime-check-eval-in-emacs-enabled)
            (slime-eval-for-lisp thread tag form-string))
--- /project/slime/cvsroot/slime/swank.lisp	2010/07/30 16:14:50	1.722
+++ /project/slime/cvsroot/slime/swank.lisp	2010/08/04 18:20:22	1.723
@@ -63,7 +63,8 @@
            #:profile-package
            #:default-directory
            #:set-default-directory
-           #:quit-lisp))
+           #:quit-lisp
+           #:eval-for-emacs))
 
 (in-package :swank)
 




From sboukarev at common-lisp.net  Wed Aug  4 18:41:04 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 04 Aug 2010 14:41:04 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1Ogitk-0002TS-JD@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv9243

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
* swank-allegro.lisp (fspec-definition-locations): Default
&optional position to 0, otherwise it may cause errors later.
Reported by: Paulo Madeira.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/04 18:20:22	1.2118
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/04 18:41:04	1.2119
@@ -1,5 +1,11 @@
 2010-08-04  Stas Boukarev  <stassats at gmail.com>
 
+	* swank-allegro.lisp (fspec-definition-locations): Default
+	&optional position to 0, otherwise it may cause errors later.
+	Reported by: Paulo Madeira.
+
+2010-08-04  Stas Boukarev  <stassats at gmail.com>
+
 	* slime.el (slime-dispatch-event): :eval-no-wait, lisp sends a
 	form in a string, not a function name and arguments. Add
 	slime-check-eval-in-emacs-enabled.
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/06/04 07:30:14	1.141
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/08/04 18:41:04	1.142
@@ -536,7 +536,7 @@
   (cond
     ((and (listp fspec)
           (eql (car fspec) :top-level-form))
-     (destructuring-bind (top-level-form file &optional position) fspec 
+     (destructuring-bind (top-level-form file &optional (position 0)) fspec 
        (declare (ignore top-level-form))
        `((,fspec
           ,(buffer-or-file-location file position)))))




From sboukarev at common-lisp.net  Thu Aug  5 12:12:34 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 05 Aug 2010 08:12:34 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OgzJK-0005ci-Ci@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv21548

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
* swank-ccl.lisp (spawn): Specify
:use-standard-initial-bindings nil, so that *readtable*
etc. modifications persist.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/04 18:41:04	1.2119
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/05 12:12:34	1.2120
@@ -1,3 +1,9 @@
+2010-08-05  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-ccl.lisp (spawn): Specify
+	:use-standard-initial-bindings nil, so that *readtable*
+	etc. modifications persist.
+
 2010-08-04  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-allegro.lisp (fspec-definition-locations): Default
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2010/05/27 14:48:19	1.20
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2010/08/05 12:12:34	1.21
@@ -677,7 +677,8 @@
   (queue '() :type list))
 
 (defimplementation spawn (fun &key name)
-  (ccl:process-run-function (or name "Anonymous (Swank)")
+  (ccl:process-run-function (list :name (or name "Anonymous (Swank)")
+                                  :use-standard-initial-bindings nil)
                             fun))
 
 (defimplementation thread-id (thread)




From sboukarev at common-lisp.net  Fri Aug  6 14:10:50 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Fri, 06 Aug 2010 10:10:50 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OhNdK-0004U6-6x@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv17233

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
* swank-ccl.lisp (spawn): Revert the previous change, using
:use-standard-initial-bindings nil might be not thread-safe.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/05 12:12:34	1.2120
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/06 14:10:50	1.2121
@@ -1,3 +1,8 @@
+2010-08-06  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-ccl.lisp (spawn): Revert the previous change, using
+	:use-standard-initial-bindings nil might be not thread-safe.
+
 2010-08-05  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-ccl.lisp (spawn): Specify
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2010/08/05 12:12:34	1.21
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2010/08/06 14:10:50	1.22
@@ -677,8 +677,7 @@
   (queue '() :type list))
 
 (defimplementation spawn (fun &key name)
-  (ccl:process-run-function (list :name (or name "Anonymous (Swank)")
-                                  :use-standard-initial-bindings nil)
+  (ccl:process-run-function (or name "Anonymous (Swank)")
                             fun))
 
 (defimplementation thread-id (thread)




From heller at common-lisp.net  Wed Aug 11 12:40:04 2010
From: heller at common-lisp.net (CVS User heller)
Date: Wed, 11 Aug 2010 08:40:04 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OjAbE-0006fG-2b@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv25390

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Bind *print-readably* to nil when printing the title.

* swank.lisp (prepare-title): Factored out into new function.
(*inspector-printer-bindings*)
(*inspector-verbose-printer-bindings*): New.
(with-string-stream): New.
(emacs-inspect/istate): Renamed from emacs-inspect/printer-bindings.

--- /project/slime/cvsroot/slime/ChangeLog	2010/08/06 14:10:50	1.2121
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/11 12:40:03	1.2122
@@ -1,3 +1,13 @@
+2010-08-11  Helmut Eller  <heller at common-lisp.net>
+
+	Bind *print-readably* to nil when printing the title.
+
+	* swank.lisp (prepare-title): Factored out into new function.
+	(*inspector-printer-bindings*)
+	(*inspector-verbose-printer-bindings*): New.
+	(with-string-stream): New.
+	(emacs-inspect/istate): Renamed from emacs-inspect/printer-bindings.
+
 2010-08-06  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-ccl.lisp (spawn): Revert the previous change, using
--- /project/slime/cvsroot/slime/swank.lisp	2010/08/04 18:20:22	1.723
+++ /project/slime/cvsroot/slime/swank.lisp	2010/08/11 12:40:03	1.724
@@ -1945,15 +1945,6 @@
       (without-printing-errors (:object object :stream nil)
         (prin1-to-string object)))))
 
-(defun to-line  (object &optional (width 75))
-  "Print OBJECT to a single line. Return the string."
-  (without-printing-errors (:object object :stream nil)
-    (call/truncated-output-to-string
-     width
-     (lambda (*standard-output*)
-       (write object :right-margin width :lines 1))
-     "..")))
-
 (defun from-string (string)
   "Read string in the *BUFFER-PACKAGE*"
   (with-buffer-syntax ()
@@ -2302,11 +2293,28 @@
                    (replace buffer ellipsis :start1 fill-pointer)
                    (return-from buffer-full buffer)))))
         (let ((stream (make-output-stream #'write-output)))
-          
           (funcall function stream)
           (finish-output stream)
           (subseq buffer 0 fill-pointer))))))
 
+(defmacro with-string-stream ((var &key length bindings)
+                              &body body)
+  (cond ((and (not bindings) (not length))
+         `(with-output-to-string (,var) . ,body))
+        ((not bindings)
+         `(call/truncated-output-to-string 
+           ,length (lambda (,var) . ,body)))
+        (t
+         `(with-bindings ,bindings 
+            (with-string-stream (,var :length ,length)
+              . ,body)))))
+
+(defun to-line  (object &optional (width 75))
+  "Print OBJECT to a single line. Return the string."
+  (without-printing-errors (:object object :stream nil)
+    (with-string-stream (stream :length width)
+      (write object :stream stream :right-margin width :lines 1))))
+
 (defun escape-string (string stream &key length (map '((#\" . "\\\"")
                                                        (#\\ . "\\\\"))))
   "Write STRING to STREAM surronded by double-quotes.
@@ -2609,13 +2617,12 @@
                  ((t) `((:restartable t)))))))
 
 (defun frame-to-string (frame)
-  (with-bindings *backtrace-printer-bindings*
-    (call/truncated-output-to-string 
-     (* (or *print-lines* 1) (or *print-right-margin* 100))
-     (lambda (stream)
-       (handler-case (print-frame frame stream)
-         (serious-condition ()
-           (format stream "[error printing frame]")))))))
+  (with-string-stream (stream :length (* (or *print-lines* 1) 
+                                         (or *print-right-margin* 100))
+                              :bindings *backtrace-printer-bindings*)
+    (handler-case (print-frame frame stream)
+      (serious-condition ()
+        (format stream "[error printing frame]")))))
 
 (defslimefun debugger-info-for-emacs (start end)
   "Return debugger state, with stack frames from START to END.
@@ -3348,7 +3355,19 @@
 
 (defvar *inspector-verbose* nil)
 
-(defstruct (inspector-state (:conc-name istate.))
+(defvar *inspector-printer-bindings*
+  '((*print-lines*        . 1) 
+    (*print-right-margin* . 75)
+    (*print-pretty*       . t)
+    (*print-readably*     . nil)))
+
+(defvar *inspector-verbose-printer-bindings*
+  '((*print-escape* . t)
+    (*print-circle* . t)
+    (*print-array*  . nil)))
+
+(defstruct inspector-state)
+(defstruct (istate (:conc-name istate.) (:include inspector-state))
   object
   (verbose *inspector-verbose*)
   (parts (make-array 10 :adjustable t :fill-pointer 0))
@@ -3378,34 +3397,38 @@
       data)))
 
 (defun inspect-object (o)
-  ;; Set *ISTATE* first so EMACS-INSPECT can possibly look at it.
-  (setq *istate* (make-inspector-state :object o :previous *istate*))
-  (setf (istate.content *istate*) (emacs-inspect/printer-bindings o))
-  (unless (find o *inspector-history*)
-    (vector-push-extend o *inspector-history*))
-  (let ((previous (istate.previous *istate*)))
-    (if previous (setf (istate.next previous) *istate*)))
-  (istate>elisp *istate*))
-
-(defun emacs-inspect/printer-bindings (object)
-  (let ((*print-lines* 1) (*print-right-margin* 75)
-        (*print-pretty* t) (*print-readably* nil))
-    (emacs-inspect object)))
+  (let* ((prev *istate*)
+         (istate (make-istate :object o :previous prev
+                              :verbose (cond (prev (istate.verbose prev))
+                                             (t *inspector-verbose*)))))
+    (setq *istate* istate)
+    (setf (istate.content istate) (emacs-inspect/istate istate))
+    (unless (find o *inspector-history*)
+      (vector-push-extend o *inspector-history*))
+    (let ((previous (istate.previous istate)))
+      (if previous (setf (istate.next previous) istate)))
+    (istate>elisp istate)))
+
+(defun emacs-inspect/istate (istate)
+  (with-bindings (if (istate.verbose istate)
+                     *inspector-verbose-printer-bindings*
+                     *inspector-printer-bindings*)
+    (emacs-inspect (istate.object istate))))
 
 (defun istate>elisp (istate)
-  (list :title (if (istate.verbose istate)
-                   (let ((*print-escape* t)
-                         (*print-circle* t)
-                         (*print-array* nil))
-                     (to-string (istate.object istate)))
-                   (call/truncated-output-to-string
-                    200
-                    (lambda (s)
-                      (print-unreadable-object
-                          ((istate.object istate) s :type t :identity t)))))
+  (list :title (prepare-title istate)
         :id (assign-index (istate.object istate) (istate.parts istate))
         :content (prepare-range istate 0 500)))
 
+(defun prepare-title (istate)
+  (if (istate.verbose istate)
+      (with-bindings *inspector-verbose-printer-bindings*
+        (to-string (istate.object istate)))
+      (with-string-stream (stream :length 200
+                                  :bindings *inspector-printer-bindings*)
+        (print-unreadable-object
+            ((istate.object istate) stream :type t :identity t)))))
+
 (defun prepare-range (istate start end)
   (let* ((range (content-range (istate.content istate) start end))
          (ps (loop for part in range append (prepare-part part istate))))
@@ -3463,8 +3486,7 @@
 
 (defslimefun inspect-nth-part (index)
   (with-buffer-syntax ()
-    (let ((*inspector-verbose* (istate.verbose *istate*)))
-      (inspect-object (inspector-nth-part index)))))
+    (inspect-object (inspector-nth-part index))))
 
 (defslimefun inspector-range (from to)
   (prepare-range *istate* from to))
@@ -3495,9 +3517,9 @@
           (t nil))))
 
 (defslimefun inspector-reinspect ()
-  (setf (istate.content *istate*)
-        (emacs-inspect/printer-bindings (istate.object *istate*)))
-  (istate>elisp *istate*))
+  (let ((istate *istate*))
+    (setf (istate.content istate) (emacs-inspect/istate istate))
+    (istate>elisp istate)))
 
 (defslimefun inspector-toggle-verbose ()
   "Toggle verbosity of inspected object."




From sboukarev at common-lisp.net  Thu Aug 12 12:09:45 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 12 Aug 2010 08:09:45 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OjWbR-00070Z-J8@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv26919

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (save-image): Fix save-lisp-and-die invocation.
Based on a patch by Anton Kovalenko.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/11 12:40:03	1.2122
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/12 12:09:45	1.2123
@@ -1,3 +1,8 @@
+2010-08-12  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-sbcl.lisp (save-image): Fix save-lisp-and-die invocation.
+	Based on a patch by Anton Kovalenko.
+
 2010-08-11  Helmut Eller  <heller at common-lisp.net>
 
 	Bind *print-readably* to nil when printing the title.
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/07/21 13:40:32	1.272
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/08/12 12:09:45	1.273
@@ -1551,10 +1551,9 @@
 (defimplementation save-image (filename &optional restart-function)
   (let ((pid (sb-posix:fork)))
     (cond ((= pid 0) 
-           (let ((args `(,filename 
-                         ,@(if restart-function
-                               `((:toplevel ,restart-function))))))
-             (apply #'sb-ext:save-lisp-and-die args)))
+           (apply #'sb-ext:save-lisp-and-die filename
+                  (when restart-function
+                    (list :toplevel restart-function))))
           (t
            (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
              (assert (= pid rpid))




From heller at common-lisp.net  Fri Aug 13 07:25:15 2010
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 13 Aug 2010 03:25:15 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Ojodf-0007ip-9X@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv29682/contrib

Modified Files:
	ChangeLog swank-snapshot.lisp 
Log Message:
Fix slime-restore.

* swank-snapshot.lisp (swank-snapshot::resurrect): Adapted to
new MAKE-CONNECTION.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/07/29 08:05:22	1.405
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/13 07:25:15	1.406
@@ -1,3 +1,10 @@
+2010-08-13  Helmut Eller  <heller at common-lisp.net>
+
+	Fix slime-restore.
+
+	* swank-snapshot.lisp (swank-snapshot::resurrect): Adapted to
+	new MAKE-CONNECTION.
+
 2010-07-29  Stas Boukarev  <stassats at gmail.com>
 
 	* slime-c-p-c.el (slime-complete-form): Limit `looking-back' too.
--- /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2009/12/22 09:31:15	1.1
+++ /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2010/08/13 07:25:15	1.2
@@ -16,8 +16,10 @@
 	 (stream (swank::connection.socket-io conn))
 	 (clone (swank-backend:dup (swank-backend:socket-fd stream)))
 	 (style (swank::connection.communication-style conn))
+	 (coding (swank::connection.coding-system conn))
 	 (args (list "--swank-fd" (format nil "~d" clone)
-		     "--swank-style" (format nil "~s" style))))
+		     "--swank-style" (format nil "~s" style)
+		     "--swank-coding" (format nil "~s" coding))))
     (swank::close-connection conn nil nil)
     (swank-backend:exec-image image-file args)))
 
@@ -30,13 +32,13 @@
   (setq *connections* (delete old-connection *connections*))
   (format *error-output* "args: ~s~%" (command-line-args))
   (let* ((fd (read-command-line-arg "--swank-fd"))
-	 (style (read-command-line-arg "--swank-style")))
-    (format *error-output* "fd=~s style=~s~%" fd style)
-    (let ((connection (create-connection (make-fd-stream fd :default) style)))
-      (run-hook *new-connection-hook* connection)
-      (push connection *connections*)
-      (serve-requests connection)
-      (simple-repl))))
+	 (style (read-command-line-arg "--swank-style"))
+	 (coding (read-command-line-arg "--swank-coding"))
+	 (* (format *error-output* "fd=~s style=~s cs=~s~%" fd style coding))
+	 (stream (make-fd-stream fd (find-external-format-or-lose coding)))
+	 (connection (make-connection nil stream style  coding)))
+    (serve-requests connection)
+    (simple-repl)))
 
 (defun read-command-line-arg (name)
   (let* ((args (command-line-args))




From heller at common-lisp.net  Fri Aug 13 07:25:23 2010
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 13 Aug 2010 03:25:23 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1Ojodn-0007jh-BO@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv29728

Modified Files:
	ChangeLog swank-cmucl.lisp 
Log Message:
Find definition for (def-vm-support-routine NAME ...)

* swank-cmucl.lisp (vm-support-routine-definitions): New.
(find-definitions): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2010/08/12 12:09:45	1.2123
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/13 07:25:23	1.2124
@@ -1,3 +1,10 @@
+2010-08-13  Helmut Eller  <heller at common-lisp.net>
+
+	Find definition for (def-vm-support-routine NAME ...)
+
+	* swank-cmucl.lisp (vm-support-routine-definitions): New.
+	(find-definitions): Use it.
+
 2010-08-12  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-sbcl.lisp (save-image): Fix save-lisp-and-die invocation.
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/07/06 12:09:20	1.225
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/08/13 07:25:23	1.226
@@ -900,7 +900,9 @@
           (function-info-definitions name)
           (ir1-translator-definitions name)
           (template-definitions name)
-          (primitive-definitions name)))
+          (primitive-definitions name)
+          (vm-support-routine-definitions name)
+          ))
 
 ;;;;; Functions, macros, generic functions, methods
 ;;;
@@ -1276,6 +1278,16 @@
          (not (eq csym name))
          (template-definitions csym))))
 
+(defun vm-support-routine-definitions (name)
+  (let ((sr (c::backend-support-routines c::*backend*))
+        (name (find-symbol (string name) :c)))
+    (and name
+         (slot-exists-p sr name)
+         (maybe-make-definition (slot-value sr name)
+                                (find-symbol (string 'vm-support-routine)
+                                             :c)
+                                name))))
+
 
 ;;;; Documentation.
 




From heller at common-lisp.net  Fri Aug 13 07:31:01 2010
From: heller at common-lisp.net (CVS User heller)
Date: Fri, 13 Aug 2010 03:31:01 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OjojF-000861-3j@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv31122

Modified Files:
	swank-cmucl.lisp 
Log Message:
(vm-support-routine-definitions): Use 'c not :c to reduce clutter in
the keyword package.

--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/08/13 07:25:23	1.226
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/08/13 07:31:01	1.227
@@ -1280,12 +1280,11 @@
 
 (defun vm-support-routine-definitions (name)
   (let ((sr (c::backend-support-routines c::*backend*))
-        (name (find-symbol (string name) :c)))
+        (name (find-symbol (string name) 'c)))
     (and name
          (slot-exists-p sr name)
          (maybe-make-definition (slot-value sr name)
-                                (find-symbol (string 'vm-support-routine)
-                                             :c)
+                                (find-symbol (string 'vm-support-routine) 'c)
                                 name))))
 
 




From sboukarev at common-lisp.net  Sun Aug 15 19:13:57 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 15 Aug 2010 15:13:57 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1Okieb-0002ku-3v@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv10574

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (setup-server): Check the coding system before doing
anything, otherwise it may be eaten by ignore-errors later.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/13 07:25:23	1.2124
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/15 19:13:56	1.2125
@@ -1,3 +1,8 @@
+2010-08-15  Stas Boukarev  <stassats at gmail.com>
+
+	* swank.lisp (setup-server): Check the coding system before doing
+	anything, otherwise it may be eaten by ignore-errors later.
+
 2010-08-13  Helmut Eller  <heller at common-lisp.net>
 
 	Find definition for (def-vm-support-routine NAME ...)
--- /project/slime/cvsroot/slime/swank.lisp	2010/08/11 12:40:03	1.724
+++ /project/slime/cvsroot/slime/swank.lisp	2010/08/15 19:13:57	1.725
@@ -817,6 +817,7 @@
 (defun setup-server (port announce-fn style dont-close coding-system)
   (declare (type function announce-fn))
   (init-log-output)
+  (find-external-format-or-lose coding-system)
   (let* ((socket (create-socket *loopback-interface* port))
          (local-port (local-port socket)))
     (funcall announce-fn local-port)
@@ -826,7 +827,7 @@
         (:spawn
          (initialize-multiprocessing
           (lambda ()
-            (spawn (lambda () 
+            (spawn (lambda ()
                      (cond ((not dont-close) (serve))
                            (t (loop (ignore-errors (serve))))))
                    :name (cat "Swank " (princ-to-string port))))))




From sboukarev at common-lisp.net  Fri Aug 20 02:48:18 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 19 Aug 2010 22:48:18 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OmHeU-00080h-QX@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv30784

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-maybe-complete-as-filename): Limit backward
search for #\", it slows down on large buffers.
Reported by Raymond Toy.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/15 19:13:56	1.2125
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/20 02:48:18	1.2126
@@ -1,3 +1,9 @@
+2010-08-20  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-maybe-complete-as-filename): Limit backward
+	search for #\", it slows down on large buffers.
+	Reported by Raymond Toy.
+
 2010-08-15  Stas Boukarev  <stassats at gmail.com>
 
 	* swank.lisp (setup-server): Check the coding system before doing
--- /project/slime/cvsroot/slime/slime.el	2010/08/04 18:20:22	1.1331
+++ /project/slime/cvsroot/slime/slime.el	2010/08/20 02:48:18	1.1332
@@ -3652,11 +3652,11 @@
 (defun slime-maybe-complete-as-filename ()
   "If point is at a string starting with \", complete it as filename.
 Return nil if point is not at filename."
-  (if (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
-      (let ((comint-completion-addsuffix '("/" . "\"")))
-        (comint-replace-by-expanded-filename)
-        t)
-    nil))
+  (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" (max (point-min)
+                                                                  (- (point) 1000)) t))
+    (let ((comint-completion-addsuffix '("/" . "\"")))
+      (comint-replace-by-expanded-filename)
+      t)))
 
 (defun slime-minibuffer-respecting-message (format &rest format-args)
   "Display TEXT as a message, without hiding any minibuffer contents."




From sboukarev at common-lisp.net  Fri Aug 20 03:42:52 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Thu, 19 Aug 2010 23:42:52 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OmIVI-0003Hs-ON@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv12626

Modified Files:
	ChangeLog slime.el 
Log Message:
(slime-search-buffer-package): Cache the package, searching every time
on large buffers may be slow.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/20 02:48:18	1.2126
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/20 03:42:52	1.2127
@@ -3,6 +3,8 @@
 	* slime.el (slime-maybe-complete-as-filename): Limit backward
 	search for #\", it slows down on large buffers.
 	Reported by Raymond Toy.
+	(slime-search-buffer-package): Cache the package, searching every time
+	on large buffers may be slow.
 
 2010-08-15  Stas Boukarev  <stassats at gmail.com>
 
--- /project/slime/cvsroot/slime/slime.el	2010/08/20 02:48:18	1.1332
+++ /project/slime/cvsroot/slime/slime.el	2010/08/20 03:42:52	1.1333
@@ -2095,6 +2095,10 @@
   "Figure out which Lisp package the current buffer is associated with."
   (funcall slime-find-buffer-package-function))
 
+(make-variable-buffer-local
+ (defvar slime-package-cache nil
+   "Cons of the form (buffer-modified-tick . package)"))
+
 ;; When modifing this code consider cases like:
 ;;  (in-package #.*foo*)
 ;;  (in-package #:cl)
@@ -2103,13 +2107,21 @@
 ;;  (in-package |CL|)
 ;;  (in-package #+ansi-cl :cl #-ansi-cl 'lisp)
 (defun slime-search-buffer-package ()
-  (let ((case-fold-search t)
-        (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*"
-                        "\\([^)]+\\)[ \t]*)")))
-    (save-excursion
-      (when (or (re-search-backward regexp nil t)
-                (re-search-forward regexp nil t))
-        (match-string-no-properties 2)))))
+  (flet ((search-package ()
+           (let ((case-fold-search t)
+                 (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*"
+                                 "\\([^)]+\\)[ \t]*)")))
+             (save-excursion
+               (when (or (re-search-backward regexp nil t)
+                         (re-search-forward regexp nil t))
+                 (match-string-no-properties 2))))))
+    (if (eql (car slime-package-cache) (buffer-modified-tick))
+        (cdr slime-package-cache)
+        (let ((package (search-package)))
+          (setf slime-package-cache
+                (cons (buffer-modified-tick)
+                      package))
+          package))))
 
 ;;; Synchronous requests are implemented in terms of asynchronous
 ;;; ones. We make an asynchronous request with a continuation function




From heller at common-lisp.net  Sat Aug 21 06:39:59 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 21 Aug 2010 02:39:59 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1OmhkF-0003eH-CK@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv14026/contrib

Modified Files:
	ChangeLog slime-snapshot.el swank-snapshot.lisp 
Log Message:
Snapshot restore support for SBCL.

* swank-backend.lisp (background-save-image): New.
* swank-sbcl.lisp (command-line-args, dup, sys-execv, exec-image)
(make-fd-stream, background-save-image): New.

Add support to save snapshots in backround.

* swank-snapshot.lisp (background-save-snapshot): New.
(resurrect): Initialize repl streams.
* slime-snapshot.el (slime-snapshot): With prefix-arg perform
saving in background.  Also ask before overwriting existing files.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/13 07:25:15	1.406
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/21 06:39:59	1.407
@@ -1,3 +1,12 @@
+2010-08-21  Anton Kovalenko <anton at sw4me.com>
+
+	Add support to save snapshots in backround.
+
+	* swank-snapshot.lisp (background-save-snapshot): New.
+	(resurrect): Initialize repl streams.
+	* slime-snapshot.el (slime-snapshot): With prefix-arg perform
+	saving in background.  Also ask before overwriting existing files.
+
 2010-08-13  Helmut Eller  <heller at common-lisp.net>
 
 	Fix slime-restore.
--- /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2010/05/28 19:13:17	1.5
+++ /project/slime/cvsroot/slime/contrib/slime-snapshot.el	2010/08/21 06:39:59	1.6
@@ -5,11 +5,20 @@
   (:license "Unknown")
   (:swank-dependencies swank-snapshot))
 
-(defun slime-snapshot (filename)
+(defun slime-snapshot (filename &optional background)
   "Save a memory image to the file FILENAME."
-  (interactive (list (read-file-name "Image file: ")))
-  (slime-eval-with-transcript 
-   `(swank-snapshot:save-snapshot ,(expand-file-name filename))))
+  (interactive (list (read-file-name "Image file: ")
+		     current-prefix-arg))
+  (let ((file (expand-file-name filename)))
+    (when (and (file-exists-p file)
+	       (not (yes-or-no-p (format "File exists %s.  Overwrite it? " 
+					 filename))))
+      (signal 'quit nil))
+    (slime-eval-with-transcript
+     `(,(if background
+	    'swank-snapshot:background-save-snapshot
+	  'swank-snapshot:save-snapshot)
+       ,file))))
 
 (defun slime-restore (filename)
   "Restore a memory image stored in file FILENAME."
--- /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2010/08/13 07:25:15	1.2
+++ /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp	2010/08/21 06:39:59	1.3
@@ -1,7 +1,7 @@
 
 (defpackage swank-snapshot
   (:use cl)
-  (:export restore-snapshot save-snapshot)
+  (:export restore-snapshot save-snapshot background-save-snapshot)
   (:import-from swank defslimefun))
 (in-package swank-snapshot)
 
@@ -9,7 +9,7 @@
   (swank-backend:save-image image-file 
 			    (let ((c swank::*emacs-connection*))
 			      (lambda () (resurrect c))))
-  t)
+  (format nil "Dumped lisp to ~A" image-file))
 
 (defslimefun restore-snapshot (image-file)
   (let* ((conn swank::*emacs-connection*)
@@ -17,12 +17,28 @@
 	 (clone (swank-backend:dup (swank-backend:socket-fd stream)))
 	 (style (swank::connection.communication-style conn))
 	 (coding (swank::connection.coding-system conn))
+	 (repl (if (swank::connection.user-io conn) t))
 	 (args (list "--swank-fd" (format nil "~d" clone)
 		     "--swank-style" (format nil "~s" style)
-		     "--swank-coding" (format nil "~s" coding))))
+		     "--swank-coding" (format nil "~s" coding)
+		     "--swank-repl" (format nil "~s" repl))))
     (swank::close-connection conn nil nil)
     (swank-backend:exec-image image-file args)))
 
+(defslimefun background-save-snapshot (image-file)
+  (let ((connection swank::*emacs-connection*))
+    (flet ((complete (success)
+	     (let ((swank::*emacs-connection* connection))
+	       (swank::background-message
+		"Dumping lisp image ~A ~:[failed!~;succeeded.~]" 
+		image-file success)))
+	   (awaken ()
+	     (resurrect connection)))
+      (swank-backend:background-save-image image-file
+					   :restart-function #'awaken
+					   :completion-function #'complete)
+      (format nil "Started dumping lisp to ~A..." image-file))))
+
 (in-package :swank)
 
 (defun swank-snapshot::resurrect (old-connection)
@@ -34,9 +50,13 @@
   (let* ((fd (read-command-line-arg "--swank-fd"))
 	 (style (read-command-line-arg "--swank-style"))
 	 (coding (read-command-line-arg "--swank-coding"))
+	 (repl (read-command-line-arg "--swank-repl"))
 	 (* (format *error-output* "fd=~s style=~s cs=~s~%" fd style coding))
 	 (stream (make-fd-stream fd (find-external-format-or-lose coding)))
 	 (connection (make-connection nil stream style  coding)))
+    (let ((*emacs-connection* connection))
+      (when repl (create-repl nil))
+      (background-message "~A" "Lisp image restored"))
     (serve-requests connection)
     (simple-repl)))
 




From heller at common-lisp.net  Sat Aug 21 06:39:59 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 21 Aug 2010 02:39:59 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OmhkF-0003eZ-Iq@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv14026

Modified Files:
	swank-backend.lisp swank-sbcl.lisp 
Log Message:
Snapshot restore support for SBCL.

* swank-backend.lisp (background-save-image): New.
* swank-sbcl.lisp (command-line-args, dup, sys-execv, exec-image)
(make-fd-stream, background-save-image): New.

Add support to save snapshots in backround.

* swank-snapshot.lisp (background-save-snapshot): New.
(resurrect): Initialize repl streams.
* slime-snapshot.el (slime-snapshot): With prefix-arg perform
saving in background.  Also ask before overwriting existing files.

--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/04/22 05:47:35	1.199
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/08/21 06:39:59	1.200
@@ -1301,5 +1301,8 @@
   "Save a heap image to the file FILENAME.
 RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
 
-
-  
\ No newline at end of file
+(definterface background-save-image (filename &key restart-function
+                                              completion-function)
+  "Request saving a heap image to the file FILENAME.
+RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
+COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/08/12 12:09:45	1.273
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/08/21 06:39:59	1.274
@@ -155,12 +155,18 @@
 (defimplementation remove-fd-handlers (socket)
   (sb-sys:invalidate-descriptor (socket-fd socket)))
 
-(defun socket-fd (socket)
+(defimplementation socket-fd (socket)
   (etypecase socket
     (fixnum socket)
     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
     (file-stream (sb-sys:fd-stream-fd socket))))
 
+(defimplementation command-line-args ()
+  sb-ext:*posix-argv*)
+
+(defimplementation dup (fd)
+  (sb-posix:dup fd))
+
 (defvar *wait-for-input-called*)
 
 (defimplementation wait-for-input (streams &optional timeout)
@@ -1549,13 +1555,87 @@
 
 #-win32
 (defimplementation save-image (filename &optional restart-function)
-  (let ((pid (sb-posix:fork)))
-    (cond ((= pid 0) 
-           (apply #'sb-ext:save-lisp-and-die filename
-                  (when restart-function
-                    (list :toplevel restart-function))))
-          (t
-           (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
-             (assert (= pid rpid))
-             (assert (and (sb-posix:wifexited status)
-                          (zerop (sb-posix:wexitstatus status)))))))))
+  (flet ((restart-sbcl ()
+           (sb-debug::enable-debugger)
+           (setf sb-impl::*descriptor-handlers* nil)
+           (funcall restart-function)))
+    (let ((pid (sb-posix:fork)))
+      (cond ((= pid 0)
+             (sb-debug::disable-debugger)
+             (apply #'sb-ext:save-lisp-and-die filename
+                    (when restart-function
+                      (list :toplevel #'restart-sbcl))))
+            (t
+             (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
+               (assert (= pid rpid))
+               (assert (and (sb-posix:wifexited status)
+                            (zerop (sb-posix:wexitstatus status))))))))))
+
+#+unix
+(progn
+  (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int 
+    (program sb-alien:c-string)
+    (argv (* sb-alien:c-string)))
+  
+  (defun execv (program args)
+    "Replace current executable with another one."
+    (let ((a-args (sb-alien:make-alien sb-alien:c-string
+                                       (+ 1 (length args)))))
+      (unwind-protect
+           (progn
+             (loop for index from 0 by 1
+                   and item in (append args '(nil))
+                   do (setf (sb-alien:deref a-args index)
+                            item))
+             (when (minusp
+                    (sys-execv program a-args))
+               (sb-posix:syscall-error)))
+        (sb-alien:free-alien a-args))))
+
+  (defimplementation exec-image (image-file args)
+    (loop with fd-arg =
+          (loop for arg in args
+                and key = "" then arg
+                when (string-equal key "--swank-fd")
+                  return (parse-integer arg))
+          for my-fd from 3 to 1024
+          when (/= my-fd fd-arg)
+            do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
+    (let* ((self-string (pathname-to-filename sb-ext:*runtime-pathname*)))
+      (execv
+       self-string
+       (apply 'list self-string "--core" image-file args)))))
+
+(defimplementation make-fd-stream (fd external-format)
+  (sb-sys:make-fd-stream fd :input t :output t
+                         :element-type 'character
+                         :buffering :full
+                         :dual-channel-p t                         
+                         :external-format external-format))
+
+(defimplementation background-save-image  (filename &key restart-function
+                                              completion-function)
+  (flet ((restart-sbcl ()
+           (sb-debug::enable-debugger)
+           (setf sb-impl::*descriptor-handlers* nil)
+           (funcall restart-function)))
+    (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
+      (let ((pid (sb-posix:fork)))
+        (cond ((= pid 0)
+               (sb-posix:close pipe-in)
+               (sb-debug::disable-debugger)
+               (apply #'sb-ext:save-lisp-and-die filename
+                      (when restart-function
+                        (list :toplevel #'restart-sbcl))))
+              (t
+               (sb-posix:close pipe-out)
+               (sb-sys:add-fd-handler
+                pipe-in :input
+                (lambda (fd)
+                  (sb-sys:invalidate-descriptor fd)
+                  (sb-posix:close fd)
+                  (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
+                    (assert (= pid rpid))
+                    (assert (sb-posix:wifexited status))
+                    (funcall completion-function
+                             (zerop (sb-posix:wexitstatus status))))))))))))




From heller at common-lisp.net  Sat Aug 21 06:40:04 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 21 Aug 2010 02:40:04 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OmhkK-0003hf-LV@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv14123

Modified Files:
	slime.el 
Log Message:
Add commands to enable/disable contribs.

* slime.el (slime-enable-contrib, slime-disable-contrib): New.
(slime-contrib): New struct to collect meta-data about contribs.
(define-slime-contrib): Store meta-data in 'slime-contribs plist.
(slime-all-contribs, slime-find-contrib, slime-read-contrib-name):
New helpers.

--- /project/slime/cvsroot/slime/slime.el	2010/08/20 03:42:52	1.1333
+++ /project/slime/cvsroot/slime/slime.el	2010/08/21 06:40:04	1.1334
@@ -6846,6 +6846,15 @@
       (setf (slime-lisp-modules) 
             (slime-eval `(swank:swank-require ',needed))))))
 
+(defstruct slime-contrib
+  name
+  slime-dependencies
+  swank-dependencies
+  enable
+  disable
+  authors
+  license)
+
 (defmacro define-slime-contrib (name docstring &rest clauses)
   (destructuring-bind (&key slime-dependencies
                             swank-dependencies
@@ -6855,6 +6864,8 @@
                             authors 
                             license)
       (loop for (key . value) in clauses append `(,key ,value))
+    (let ((enable (intern (concat (symbol-name name) "-init")))
+          (disable (intern (concat (symbol-name name) "-unload"))))
     `(progn
        ,(when gnu-emacs-only
           `(eval-and-compile
@@ -6862,15 +6873,46 @@
                      ,(concat (symbol-name name)
                               " does not work with XEmacs."))))
        ,@(mapcar (lambda (d) `(require ',d)) slime-dependencies)
-       (defun ,(intern (concat (symbol-name name) "-init")) ()
+       (defun ,enable ()
          ,@(mapcar (lambda (d) `(slime-require ',d)) swank-dependencies)
          , at on-load)
-       (defun ,(intern (concat (symbol-name name) "-unload")) ()
-         , at on-unload))))
+       (defun ,disable ()
+         , at on-unload)
+       (put 'slime-contribs ',name 
+            (make-slime-contrib
+             :name ',name :authors ',authors :license ',license
+             :slime-dependencies ',slime-dependencies
+             :swank-dependencies ',swank-dependencies
+             :enable ',enable :disable ',disable))))))
 
 (put 'define-slime-contrib 'lisp-indent-function 1)
 (put 'slime-indulge-pretty-colors 'define-slime-contrib t)
 
+(defun slime-all-contribs ()
+  (loop for (name val) on (symbol-plist 'slime-contribs) by #'cddr
+        when (slime-contrib-p val)
+        collect val))
+
+(defun slime-find-contrib (name)
+  (get 'slime-contribs name))
+
+(defun slime-read-contrib-name ()
+  (let ((names (loop for c in (slime-all-contribs) collect 
+                     (symbol-name (slime-contrib-name c)))))
+    (intern (completing-read "Contrib: " names nil t))))
+  
+(defun slime-enable-contrib (name)
+  (interactive (list (slime-read-contrib-name)))
+  (let ((c (or (slime-find-contrib name)
+               (error "Unknown contrib: %S" name))))
+    (funcall (slime-contrib-enable c))))
+
+(defun slime-disable-contrib (name)
+  (interactive (list (slime-read-contrib-name)))
+  (let ((c (or (slime-find-contrib name)
+               (error "Unknown contrib: %S" name))))
+    (funcall (slime-contrib-disable c))))
+  
 
 ;;;;; Pull-down menu
 




From heller at common-lisp.net  Sat Aug 21 06:40:08 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 21 Aug 2010 02:40:08 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1OmhkO-0003mN-Fw@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv14415/contrib

Modified Files:
	ChangeLog 
Log Message:
* slime-repl.el: Specify :on-unload action.

--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/21 06:39:59	1.407
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/21 06:40:08	1.408
@@ -1,3 +1,7 @@
+2010-08-21  Helmut Eller  <heller at common-lisp.net>
+
+	* slime-repl.el: Specify :on-unload action.
+
 2010-08-21  Anton Kovalenko <anton at sw4me.com>
 
 	Add support to save snapshots in backround.




From heller at common-lisp.net  Sat Aug 21 06:40:12 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 21 Aug 2010 02:40:12 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1OmhkS-0003rQ-FJ@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv14755/contrib

Modified Files:
	slime-repl.el 
Log Message:
* slime-repl.el: Specify :on-unload action.

--- /project/slime/cvsroot/slime/contrib/slime-repl.el	2010/07/16 07:34:23	1.47
+++ /project/slime/cvsroot/slime/contrib/slime-repl.el	2010/08/21 06:40:12	1.48
@@ -29,7 +29,8 @@
   (:on-load
    (add-hook 'slime-event-hooks 'slime-repl-event-hook-function)
    (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
-   (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package)))
+   (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package))
+  (:on-unload (slime-repl-remove-hooks)))
 
 ;;;;; slime-repl
 




From heller at common-lisp.net  Sat Aug 21 06:42:14 2010
From: heller at common-lisp.net (CVS User heller)
Date: Sat, 21 Aug 2010 02:42:14 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OmhmQ-0004Ni-8n@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv16843

Modified Files:
	ChangeLog 
Log Message:
*** empty log message ***

--- /project/slime/cvsroot/slime/ChangeLog	2010/08/20 03:42:52	1.2127
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/21 06:42:14	1.2128
@@ -1,3 +1,21 @@
+2010-08-21  Helmut Eller  <heller at common-lisp.net>
+
+	Add commands to enable/disable contribs.
+
+	* slime.el (slime-enable-contrib, slime-disable-contrib): New.
+	(slime-contrib): New struct to collect meta-data about contribs.
+	(define-slime-contrib): Store meta-data in 'slime-contribs plist.
+	(slime-all-contribs, slime-find-contrib, slime-read-contrib-name):
+	New helpers.
+
+2010-08-21  Anton Kovalenko <anton at sw4me.com>
+
+	Snapshot restore support for SBCL.
+
+	* swank-backend.lisp (background-save-image): New.
+	* swank-sbcl.lisp (command-line-args, dup, sys-execv, exec-image)
+	(make-fd-stream, background-save-image): New.
+
 2010-08-20  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-maybe-complete-as-filename): Limit backward




From sboukarev at common-lisp.net  Sat Aug 21 21:31:28 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 21 Aug 2010 17:31:28 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1Omvey-0000JH-Ja@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv1192

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-recompute-modelines): Recompute modelines only
for visible buffers. Kludge: modeline can be out of sync if the buffer
becomes visible and no slime/lisp interaction took place yet.
Patch by Raymond Toy.
(slime-search-buffer-package): Revert, with the above
change caching shouldn't be necessary.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/21 06:42:14	1.2128
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/21 21:31:28	1.2129
@@ -1,3 +1,12 @@
+2010-08-21  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-recompute-modelines): Recompute modelines only
+	for visible buffers. Kludge: modeline can be out of sync if the buffer
+	becomes visible and no slime/lisp interaction took place yet.
+	Patch by Raymond Toy.
+	(slime-search-buffer-package): Revert, with the above
+	change caching shouldn't be necessary.
+
 2010-08-21  Helmut Eller  <heller at common-lisp.net>
 
 	Add commands to enable/disable contribs.
--- /project/slime/cvsroot/slime/slime.el	2010/08/21 06:40:04	1.1334
+++ /project/slime/cvsroot/slime/slime.el	2010/08/21 21:31:28	1.1335
@@ -416,7 +416,8 @@
   nil
   slime-mode-indirect-map
   (slime-setup-command-hooks)
-  (slime-recompute-modelines))
+  (setq slime-modeline-string (slime-modeline-string)))
+
 
 
 ;;;;;; Modeline
@@ -470,13 +471,24 @@
                  ((zerop sldbs) (format " %s" pending))
                  (t (format " %s/%s" pending sldbs)))))))
 
-(defun slime-recompute-modelines ()
-  (when (featurep 'xemacs)
-    (dolist (buffer (buffer-list))
-      (with-current-buffer buffer
-        (when (or slime-mode slime-popup-buffer-mode)
-          (setq slime-modeline-string (slime-modeline-string)))))
-    (force-mode-line-update t)))
+(defmacro slime-recompute-modelines ()
+  ;; Avoid a needless runtime funcall on GNU Emacs:
+  (and (featurep 'xemacs) `(slime-xemacs-recompute-modelines)))
+
+(defun slime-xemacs-recompute-modelines ()
+  (let (redraw-modeline)
+    (walk-windows
+     (lambda (object)
+       (setq object (window-buffer object))
+       (when (or (symbol-value-in-buffer 'slime-mode object)
+                 (symbol-value-in-buffer 'slime-popup-buffer-mode object))
+         ;; Only do the unwind-protect of #'with-current-buffer if we're
+         ;; actually interested in this buffer
+         (with-current-buffer object
+           (setq slime-modeline-string (slime-modeline-string)
+                 redraw-modeline t))))
+     'never t)
+    (and redraw-modeline (redraw-modeline t))))
 
 
 ;;;;; Key bindings
@@ -2106,22 +2118,15 @@
 ;;  (in-package "CL")
 ;;  (in-package |CL|)
 ;;  (in-package #+ansi-cl :cl #-ansi-cl 'lisp)
+
 (defun slime-search-buffer-package ()
-  (flet ((search-package ()
-           (let ((case-fold-search t)
-                 (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*"
-                                 "\\([^)]+\\)[ \t]*)")))
-             (save-excursion
-               (when (or (re-search-backward regexp nil t)
-                         (re-search-forward regexp nil t))
-                 (match-string-no-properties 2))))))
-    (if (eql (car slime-package-cache) (buffer-modified-tick))
-        (cdr slime-package-cache)
-        (let ((package (search-package)))
-          (setf slime-package-cache
-                (cons (buffer-modified-tick)
-                      package))
-          package))))
+  (let ((case-fold-search t)
+        (regexp (concat "^(\\(cl:\\|common-lisp:\\)?in-package\\>[ \t']*"
+                        "\\([^)]+\\)[ \t]*)")))
+    (save-excursion
+      (when (or (re-search-backward regexp nil t)
+                (re-search-forward regexp nil t))
+        (match-string-no-properties 2)))))
 
 ;;; Synchronous requests are implemented in terms of asynchronous
 ;;; ones. We make an asynchronous request with a continuation function




From sboukarev at common-lisp.net  Sat Aug 21 21:34:14 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 21 Aug 2010 17:34:14 -0400
Subject: [slime-cvs] CVS slime/contrib
Message-ID: <E1Omvhe-0000Ta-3c@common-lisp.net>

Update of /project/slime/cvsroot/slime/contrib
In directory cl-net:/tmp/cvs-serv1799

Modified Files:
	ChangeLog slime-fuzzy.el 
Log Message:
* slime-fuzzy.el (slime-fuzzy-choices-buffer): XEmacs compatibility.


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/21 06:40:08	1.408
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2010/08/21 21:34:12	1.409
@@ -1,3 +1,7 @@
+2010-08-21  Stas Boukarev  <stassats at gmail.com>
+
+	* slime-fuzzy.el (slime-fuzzy-choices-buffer): XEmacs compatibility.
+
 2010-08-21  Helmut Eller  <heller at common-lisp.net>
 
 	* slime-repl.el: Specify :on-unload action.
--- /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2010/05/28 14:15:30	1.20
+++ /project/slime/cvsroot/slime/contrib/slime-fuzzy.el	2010/08/21 21:34:12	1.21
@@ -367,7 +367,10 @@
       (setq buffer-quit-function 'slime-fuzzy-abort)) ; M-Esc Esc
     (when slime-fuzzy-completion-in-place
       ;; switch back to the original buffer
-      (if (minibufferp slime-fuzzy-target-buffer)
+      (if (if (featurep 'xemacs)
+              (eq (window-buffer (minibuffer-window))
+                  slime-fuzzy-target-buffer)
+              (minibufferp slime-fuzzy-target-buffer))
           (select-window (minibuffer-window))
           (switch-to-buffer-other-window slime-fuzzy-target-buffer)))))
 
@@ -581,4 +584,4 @@
 configuration was changed, we nullify our saved configuration."
   (setq slime-fuzzy-saved-window-configuration nil))
 
-(provide 'slime-fuzzy)
\ No newline at end of file
+(provide 'slime-fuzzy)




From sboukarev at common-lisp.net  Sun Aug 22 10:51:11 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sun, 22 Aug 2010 06:51:11 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1On88t-00036E-6g@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv11889

Modified Files:
	ChangeLog slime.el 
Log Message:
* slime.el (slime-xemacs-recompute-modelines): Add
`slime-xemacs-recompute-modelines' to `pre-idle-hook', this solves
the problem of synchronization of modelines.
Thanks to Aidan Kehoe.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/21 21:31:28	1.2129
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/22 10:51:10	1.2130
@@ -1,3 +1,10 @@
+2010-08-22  Stas Boukarev  <stassats at gmail.com>
+
+	* slime.el (slime-xemacs-recompute-modelines): Add
+	`slime-xemacs-recompute-modelines' to `pre-idle-hook', this solves
+	the problem of synchronization of modelines.
+	Thanks to Aidan Kehoe.
+
 2010-08-21  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-recompute-modelines): Recompute modelines only
--- /project/slime/cvsroot/slime/slime.el	2010/08/21 21:31:28	1.1335
+++ /project/slime/cvsroot/slime/slime.el	2010/08/22 10:51:11	1.1336
@@ -485,11 +485,17 @@
          ;; Only do the unwind-protect of #'with-current-buffer if we're
          ;; actually interested in this buffer
          (with-current-buffer object
-           (setq slime-modeline-string (slime-modeline-string)
-                 redraw-modeline t))))
-     'never t)
+           (setq redraw-modeline
+                 (or (not (equal slime-modeline-string
+                                 (setq slime-modeline-string
+                                       (slime-modeline-string))))
+                     redraw-modeline)))))
+     'never 'visible)
     (and redraw-modeline (redraw-modeline t))))
 
+(and (featurep 'xemacs)
+     (pushnew 'slime-xemacs-recompute-modelines pre-idle-hook))
+
 
 ;;;;; Key bindings
 




From sboukarev at common-lisp.net  Wed Aug 25 08:20:09 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Wed, 25 Aug 2010 04:20:09 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OoBDN-0005nM-Lw@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv21707

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (exec-image): Use (car sb-ext:*posix-argv*) if
SBCL doesn't have sb-ext:*runtime-pathname*.
Reported by Vinay.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/22 10:51:10	1.2130
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/25 08:20:09	1.2131
@@ -1,3 +1,9 @@
+2010-08-25  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-sbcl.lisp (exec-image): Use (car sb-ext:*posix-argv*) if
+	SBCL doesn't have sb-ext:*runtime-pathname*.
+	Reported by Vinay.
+
 2010-08-22  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-xemacs-recompute-modelines): Add
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/08/21 06:39:59	1.274
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/08/25 08:20:09	1.275
@@ -1592,16 +1592,24 @@
                (sb-posix:syscall-error)))
         (sb-alien:free-alien a-args))))
 
+  (defun runtime-pathname ()
+    #+#.(swank-backend:with-symbol
+            '*runtime-pathname* 'sb-ext)
+    sb-ext:*runtime-pathname*
+    #-#.(swank-backend:with-symbol
+            '*runtime-pathname* 'sb-ext)
+    (car sb-ext:*posix-argv*))
+
   (defimplementation exec-image (image-file args)
     (loop with fd-arg =
           (loop for arg in args
                 and key = "" then arg
                 when (string-equal key "--swank-fd")
-                  return (parse-integer arg))
+                return (parse-integer arg))
           for my-fd from 3 to 1024
           when (/= my-fd fd-arg)
-            do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
-    (let* ((self-string (pathname-to-filename sb-ext:*runtime-pathname*)))
+          do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
+    (let* ((self-string (pathname-to-filename (runtime-pathname))))
       (execv
        self-string
        (apply 'list self-string "--core" image-file args)))))




From sboukarev at common-lisp.net  Sun Aug 29 00:00:09 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Sat, 28 Aug 2010 20:00:09 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OpVJh-00061A-Rq@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv21703

Modified Files:
	ChangeLog swank-cmucl.lisp 
Log Message:
* swank-cmucl.lisp (*gdb-program-name*): Determine gdb location
from PATH.
(gdb-exec): Use *gdb-program-name* instead of "gdb".
(gdb-command): Mac OS X compatibility.
Patch by Raymond Toy.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/25 08:20:09	1.2131
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/29 00:00:09	1.2132
@@ -1,3 +1,11 @@
+2010-08-28  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-cmucl.lisp (*gdb-program-name*): Determine gdb location
+	from PATH.
+	(gdb-exec): Use *gdb-program-name* instead of "gdb".
+	(gdb-command): Mac OS X compatibility.
+	Patch by Raymond Toy.
+
 2010-08-25  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-sbcl.lisp (exec-image): Use (car sb-ext:*posix-argv*) if
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/08/13 07:31:01	1.227
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/08/29 00:00:09	1.228
@@ -1892,7 +1892,10 @@
 ~8X  Saved Instruction Pointer~%" (mapcar #'fixnum 
                       (multiple-value-list (frame-registers frame)))))))
 
-(defvar *gdb-program-name* "/usr/bin/gdb")
+(defvar *gdb-program-name*
+  (ext:enumerate-search-list (p "path:gdb")
+    (when (probe-file p)
+      (return p))))
 
 (defimplementation disassemble-frame (frame-number)
   (print-frame-registers frame-number)
@@ -1924,20 +1927,24 @@
       (delete-file name))))
 
 (defun gdb-command (format-string &rest args)
-  (let ((str (gdb-exec (format nil 
+  (let ((str (gdb-exec (format nil
                                "interpreter-exec mi2 \"attach ~d\"~%~
                                 interpreter-exec console ~s~%detach"
                                (getpid)
                                (apply #'format nil format-string args))))
-        (prompt (format nil "~%^done~%(gdb) ~%")))
-    (subseq str (+ (search prompt str) (length prompt)))))
+        (prompt (format nil
+                        #-(and darwin x86) "~%^done~%(gdb) ~%"
+                        #+(and darwin x86)
+"~%^done,thread-id=\"1\"~%(gdb) ~%")))
+    (subseq str (+ (or (search prompt str) 0) (length prompt)))))
 
 (defun gdb-exec (cmd)
   (with-temporary-file (file filename)
     (write-string cmd file)
     (force-output file)
     (let* ((output (make-string-output-stream))
-           (proc (ext:run-program "gdb" `("-batch" "-x" ,filename) 
+           (proc (ext:run-program *gdb-program-name*
+                                  `("-batch" "-x" ,filename) 
                                   :wait t
                                   :output output)))
       (assert (eq (ext:process-status proc) :exited))




From nsiivola at common-lisp.net  Tue Aug 31 10:33:16 2010
From: nsiivola at common-lisp.net (CVS User nsiivola)
Date: Tue, 31 Aug 2010 06:33:16 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OqO9U-00007l-1w@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv477

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
sbcl: Better VOP descriptions for XREF buffers

--- /project/slime/cvsroot/slime/ChangeLog	2010/08/29 00:00:09	1.2132
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/31 10:33:15	1.2133
@@ -1,3 +1,9 @@
+2010-08-31  Nikodemus Siivola  <nikodemus at random-state.net>
+
+	* swank-sbcl.lisp (make-dspec): Elide the function name when
+	generating a VOP description, since the VOP name is more useful
+	and is the first part of the source-description list.
+
 2010-08-28  Stas Boukarev  <stassats at gmail.com>
 
 	* swank-cmucl.lisp (*gdb-program-name*): Determine gdb location
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/08/25 08:20:09	1.275
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2010/08/31 10:33:15	1.276
@@ -688,9 +688,18 @@
       (getf *definition-types* type)))
 
 (defun make-dspec (type name source-location)
-  (list* (definition-specifier type name)
-         name
-         (sb-introspect::definition-source-description source-location)))
+  (let ((spec (definition-specifier type name))
+        (desc (sb-introspect::definition-source-description source-location)))
+    (if (eq :define-vop spec)
+        ;; The first part of the VOP description is the name of the template
+        ;; -- which is actually good information and often long. So elide the
+        ;; original name in favor of making the interesting bit more visible.
+        ;;
+        ;; The second part of the VOP description is the associated compiler note, or
+        ;; NIL -- which is quite uninteresting and confuses the eye when reading the actual
+        ;; name which usually has a worthwhile postfix. So drop the note.
+        (list spec (car desc))
+        (list* spec name desc))))
 
 (defimplementation find-definitions (name)
   (loop for type in *definition-types* by #'cddr




From sboukarev at common-lisp.net  Tue Aug 31 23:44:40 2010
From: sboukarev at common-lisp.net (CVS User sboukarev)
Date: Tue, 31 Aug 2010 19:44:40 -0400
Subject: [slime-cvs] CVS slime
Message-ID: <E1OqaVM-0001Bg-VR@common-lisp.net>

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv4552

Modified Files:
	ChangeLog swank-cmucl.lisp 
Log Message:
* swank-cmucl.lisp (foreign-frame-p, gdb-exec, frame-ip): Sparc
support.
Patch by Raymond Toy.


--- /project/slime/cvsroot/slime/ChangeLog	2010/08/31 10:33:15	1.2133
+++ /project/slime/cvsroot/slime/ChangeLog	2010/08/31 23:44:40	1.2134
@@ -1,3 +1,9 @@
+2010-08-31  Stas Boukarev  <stassats at gmail.com>
+
+	* swank-cmucl.lisp (foreign-frame-p, gdb-exec, frame-ip): Sparc
+	support.
+	Patch by Raymond Toy.
+
 2010-08-31  Nikodemus Siivola  <nikodemus at random-state.net>
 
 	* swank-sbcl.lisp (make-dspec): Elide the function name when
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/08/29 00:00:09	1.228
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2010/08/31 23:44:40	1.229
@@ -1863,7 +1863,22 @@
              (values ip pc)))
           (di::interpreted-debug-function -1)
           (di::bogus-debug-function
-           #-x86 -1
+           #-x86
+           (let* ((real (di::frame-real-frame (di::frame-up frame)))
+                  (fp (di::frame-pointer real)))
+             ;;#+(or)
+             (progn
+               (format *debug-io* "Frame-real-frame = ~S~%" real)
+               (format *debug-io* "fp = ~S~%" fp)
+               (format *debug-io* "lra = ~S~%"
+                       (kernel:stack-ref fp vm::lra-save-offset)))
+             (values 
+              (sys:int-sap
+               (- (kernel:get-lisp-obj-address
+                   (kernel:stack-ref fp vm::lra-save-offset))
+                  (- (ash vm:function-code-offset vm:word-shift)
+                     vm:function-pointer-type)))
+              0))
            #+x86
            (let ((fp (di::frame-pointer (di:frame-up frame))))
              (multiple-value-bind (ra ofp) (di::x86-call-context fp)
@@ -1943,8 +1958,23 @@
     (write-string cmd file)
     (force-output file)
     (let* ((output (make-string-output-stream))
+           ;; gdb on sparc needs to know the executable to find the
+           ;; symbols.  Without this, gdb can't disassemble anything.
+           ;; NOTE: We assume that the first entry in
+           ;; lisp::*cmucl-lib* is the bin directory where lisp is
+           ;; located.  If this is not true, we'll have to do
+           ;; something better to find the lisp executable.
+           (lisp-path
+            #+sparc
+             (list
+              (namestring
+               (probe-file
+                (merge-pathnames "lisp" (car (lisp::parse-unix-search-path
+                                              lisp::*cmucl-lib*))))))
+             #-sparc
+             nil)
            (proc (ext:run-program *gdb-program-name*
-                                  `("-batch" "-x" ,filename) 
+                                  `(, at lisp-path "-batch" "-x" ,filename)
                                   :wait t
                                   :output output)))
       (assert (eq (ext:process-status proc) :exited))
@@ -1952,13 +1982,17 @@
       (get-output-stream-string output))))
 
 (defun foreign-frame-p (frame)
-  #-x86 nil
-  #+x86 (let ((ip (frame-ip frame)))
-          (and (sys:system-area-pointer-p ip)
-               (multiple-value-bind (pc code)
-                   (di::compute-lra-data-from-pc ip)
-                 (declare (ignore pc))
-                 (not code)))))
+  #-x86
+  (let ((ip (frame-ip frame)))
+    (and (sys:system-area-pointer-p ip)
+         (typep (di::frame-debug-function frame) 'di::bogus-debug-function)))
+  #+x86
+  (let ((ip (frame-ip frame)))
+    (and (sys:system-area-pointer-p ip)
+         (multiple-value-bind (pc code)
+             (di::compute-lra-data-from-pc ip)
+           (declare (ignore pc))
+           (not code)))))
 
 (defun foreign-frame-source-location (frame)
   (let ((ip (sys:sap-int (frame-ip frame))))