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

[Helmut Eller]

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

Modified Files:
	swank-cmucl.lisp 
Log Message:
(read-next-form): Isn't quite portable. Redefine it here.
(read-symbol/package): Deleted. (Was not used.)
(function-source-location): Deal with struct-slot setters.
Date: Thu Oct 16 07:10:48 2003
Author: heller

Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.3 slime/swank-cmucl.lisp:1.4
--- slime/swank-cmucl.lisp:1.3	Wed Oct 15 18:48:30 2003
+++ slime/swank-cmucl.lisp	Thu Oct 16 07:10:48 2003
@@ -82,14 +82,16 @@
 	(sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
  	(close *emacs-io*)))))
 
-
-(defun read-symbol/package (symbol-name package-name)
-  (let ((package (find-package package-name)))
-    (unless package (error "No such package: ~S" package-name))
-    (handler-case 
-        (let ((*package* package))
-          (read-from-string symbol-name))
-      (reader-error () nil))))
+(defun read-next-form ()
+  (handler-case 
+      (let* ((length (logior (ash (read-byte *emacs-io*) 16)
+			     (ash (read-byte *emacs-io*) 8)
+			     (read-byte *emacs-io*)))
+	     (string (make-string length)))
+	(sys:read-n-bytes *emacs-io* string 0 length)
+	(read-form string))
+    (condition (c)
+      (throw 'serve-request-catcher c))))
 
 ;;; Asynchronous eval
 
@@ -128,8 +130,6 @@
 
 ;;;; Compilation Commands
 
-
-
 (defvar *previous-compiler-condition* nil
   "Used to detect duplicates.")
 
@@ -508,21 +508,25 @@
 	   (vm::find-code-object function))
        (not (eq closure function))))
 
-(defun struct-accessor-p (function)
-  (function-code-object= function #'kernel::structure-slot-accessor))
+(defun struct-closure-p (function)
+  (or (function-code-object= function #'kernel::structure-slot-accessor)
+      (function-code-object= function #'kernel::structure-slot-setter)
+      (function-code-object= function #'kernel::%defstruct)))
 
-(defun struct-accessor-dd (function)
-  (kernel:layout-info (kernel:%closure-index-ref function 2)))
-
-(defun struct-misc-op-p (function)
-  (function-code-object= function #'kernel::%defstruct))
-
-(defun struct-misc-op-dd (function)
+(defun struct-closure-dd (function)
   (assert (= (kernel:get-type function) vm:closure-header-type))
-  (kernel:layout-info
-   (c:value-cell-ref 
-    (sys:find-if-in-closure #'di::indirect-value-cell-p function))))
-
+  (flet ((find-layout (function)
+	   (sys:find-if-in-closure 
+	    (lambda (x) 
+	      (cond ((kernel::layout-p x)
+		     (return-from find-layout x))
+		    ((di::indirect-value-cell-p x)
+		     (let ((value (c:value-cell-ref x)))
+		       (when (kernel::layout-p value)
+			 (return-from find-layout value))))))
+	    function)))
+    (kernel:layout-info (find-layout function))))
+	    
 (defun dd-source-location (dd)
   (let ((constructor (or (kernel:dd-default-constructor dd)
 			 (car (kernel::dd-constructors dd)))))
@@ -543,10 +547,8 @@
   ;;
   ;; For an ordinary function we return the source location of the
   ;; first code-location we find.
-  (cond ((struct-accessor-p function)
-	 (dd-source-location (struct-accessor-dd function)))
-	((struct-misc-op-p function)
-	 (dd-source-location (struct-misc-op-dd function)))
+  (cond ((struct-closure-p function)
+	 (dd-source-location (struct-closure-dd function)))
 	(t
          (let ((location (function-first-code-location function)))
            (when location
@@ -964,7 +966,7 @@
 
 (defslimefun describe-inspectee ()
   "Describe the currently inspected object."
-  (print-desciption-to-string *inspectee*))
+  (print-description-to-string *inspectee*))
 
 (defgeneric inspected-parts (object)
   (:documentation