[slime-cvs] CVS slime

[CVS User heller]

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

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (with-definition-source): Forgot to commit this
one.

--- /project/slime/cvsroot/slime/ChangeLog	2012/05/06 16:16:02	1.2332
+++ /project/slime/cvsroot/slime/ChangeLog	2012/05/06 16:16:13	1.2333
@@ -1,5 +1,8 @@
 2012-05-06  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-sbcl.lisp (with-definition-source): Forgot to commit this
+	one.
+
 	* swank-allegro.lisp (string-to-utf8): Set the :null-terminate
 	argument of excl:string-to-octets to nil.
 
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/05/04 11:16:40	1.315
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/05/06 16:16:13	1.316
@@ -1,4 +1,4 @@
-;;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;;; -*- indent-tabs-mode: nil -*-
 ;;;
 ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
 ;;;
@@ -786,11 +786,28 @@
                                      (general-type-of obj)
                                      (to-string obj))))))
 
+(defmacro with-definition-source ((&rest names) obj &body body)
+  "Like with-slots but works only for structs."
+  (flet ((reader (slot)
+           ;; Use read-from-string instead of intern so that
+           ;; conc-name can be a string such as ext:struct- and not
+           ;; cause errors and not force interning ext::struct-
+           (read-from-string
+            (concatenate 'string "sb-introspect:definition-source-" 
+                         (string slot)))))
+    (let ((tmp (gensym "OO-")))
+      ` (let ((,tmp ,obj))
+          (symbol-macrolet
+              ,(loop for name in names collect 
+                     (typecase name
+                       (symbol `(,name (,(reader name) ,tmp)))
+                       (cons `(,(first name) (,(reader (second name)) ,tmp)))
+                       (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
+            , at body)))))
 
 (defun categorize-definition-source (definition-source)
-  (with-struct ("sb-introspect:definition-source-"
-                pathname form-path character-offset plist)
-               definition-source
+  (with-definition-source (pathname form-path character-offset plist)
+    definition-source
     (let ((file-p (and pathname (probe-file pathname)
                        (or form-path character-offset))))
       (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
@@ -800,9 +817,7 @@
             (t :invalid)))))
 
 (defun definition-source-buffer-location (definition-source)
-  (with-struct ("sb-introspect:definition-source-"
-                form-path character-offset plist)
-               definition-source
+  (with-definition-source (form-path character-offset plist) definition-source
     (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
                               emacs-string &allow-other-keys)
         plist
@@ -823,9 +838,8 @@
                       (min end (+ start *source-snippet-size*))))))))))
 
 (defun definition-source-file-location (definition-source)
-  (with-struct ("sb-introspect:definition-source-"
-                pathname form-path character-offset plist
-                file-write-date) definition-source
+  (with-definition-source (pathname form-path character-offset plist 
+                                    file-write-date) definition-source
     (let* ((namestring (namestring (translate-logical-pathname pathname)))
            (pos (if form-path
                     (source-file-position namestring file-write-date 
@@ -848,10 +862,9 @@
                    (location-hints buffer))))
 
 (defun definition-source-for-emacs (definition-source type name)
-  (with-struct ("sb-introspect:definition-source-"
-                pathname form-path character-offset plist
-                file-write-date)
-               definition-source
+  (with-definition-source (pathname form-path character-offset plist
+                                    file-write-date)
+      definition-source
     (ecase (categorize-definition-source definition-source)
       (:buffer-and-file
        (definition-source-buffer-and-file-location definition-source))
@@ -1623,7 +1636,7 @@
   #+sb-lutex
   (defun condition-timed-wait (waitqueue mutex timeout)
     (declare (ignore timeout))
-    (sb-thread:condition-wait waitqueue mutex))
+    (sb-thread:condition-wait waitqueue mutex   ))
   
   (defimplementation receive-if (test &optional timeout)
     (let* ((mbox (mailbox (current-thread)))