[slime-cvs] CVS slime

[CVS User heller]

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

Modified Files:
	ChangeLog swank-cmucl.lisp 
Log Message:
* swank-cmucl.lisp (dd-location): Use info db as fallback.
(struct-constructor): Return the name not the function.

--- /project/slime/cvsroot/slime/ChangeLog	2012/10/27 17:53:39	1.2358
+++ /project/slime/cvsroot/slime/ChangeLog	2012/10/30 18:38:33	1.2359
@@ -1,3 +1,8 @@
+2012-10-30  Helmut Eller  <heller at common-lisp.net>
+
+	* swank-cmucl.lisp (dd-location): Use info db as fallback.
+	(struct-constructor): Return the name not the function.
+
 2012-10-27  Helmut Eller  <heller at common-lisp.net>
 
 	* slime.el (report-condition-with-circular-list): New test.
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2012/08/04 23:48:19	1.244
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2012/10/30 18:38:33	1.245
@@ -1036,18 +1036,23 @@
 
 (defun dd-location (dd)
   "Return the location of a `defstruct'."
-  ;; Find the location in a constructor.
-  (function-location (struct-constructor dd)))
+  (let ((ctor (struct-constructor dd)))
+    (cond (ctor
+           (function-location (coerce ctor 'function)))
+          (t
+           (let ((name (kernel:dd-name dd)))
+             (multiple-value-bind (location foundp)
+                 (ext:info :source-location :defvar name)
+               (cond (foundp
+                      (resolve-source-location location))
+                     (t
+                      (error "No location for defstruct: ~S" name)))))))))
 
 (defun struct-constructor (dd)
-  "Return a constructor function from a defstruct definition.
-Signal an error if no constructor can be found."
+  "Return the name of the constructor from a defstruct definition."
   (let* ((constructor (or (kernel:dd-default-constructor dd)
-                          (car (kernel::dd-constructors dd))))
-         (sym (if (consp constructor) (car constructor) constructor)))
-    (unless sym
-      (error "Cannot find structure's constructor: ~S" (kernel::dd-name dd)))
-    (coerce sym 'function)))
+                          (car (kernel::dd-constructors dd)))))
+    (if (consp constructor) (car constructor) constructor)))
 
 ;;;;;; Generic functions and methods