[cl-store-cvs] CVS cl-store/sbcl

[sross]

Update of /project/cl-store/cvsroot/cl-store/sbcl
In directory clnet:/tmp/cvs-serv22833/sbcl

Modified Files:
	custom.lisp 
Log Message:
Fixed structure definition storing for more recent sbcl versions.


--- /project/cl-store/cvsroot/cl-store/sbcl/custom.lisp	2005/10/04 08:14:02	1.10
+++ /project/cl-store/cvsroot/cl-store/sbcl/custom.lisp	2006/03/14 10:58:59	1.11
@@ -101,11 +101,36 @@
   (funcall (compile nil `(lambda () ,@(sbcl-struct-defs dd))))
   (find-class (dd-name dd)))
 
+;; From 0.9.6.25 sb-kernel::%defstruct
+;; takes a source location as a third argument.
+(eval-when (:compile-toplevel)
+  (labels ((make-version (string)
+             (map-into (make-list 4 :initial-element 0)
+                       #'parse-integer
+                       (asdf::split string nil '(#\.))))
+           (version>= (v1 v2)
+             (loop for x in (make-version v1)
+                   for y in (make-version v2)
+                   when (> x y) :do (return t)
+                   when (> y x) :do (return nil)
+                   finally (return t))))
+    (when (version>= (lisp-implementation-version)
+                     "0.9.6.25")
+      (pushnew :defstruct-has-source-location *features*))))
+
+asdf::version-satisfies
+(defun sb-kernel-defstruct (dd supers source)
+  (declare (ignorable source))
+  #+defstruct-has-source-location 
+  (sb-kernel::%defstruct dd supers source)
+  #-defstruct-has-source-location
+  (sb-kernel::%defstruct dd supers))
+
 (defun sbcl-define-structure (dd supers)
   (cond ((or *nuke-existing-classes*  
              (not (find-class (dd-name dd) nil)))
          ;; create-struct
-         (sb-kernel::%defstruct dd supers)
+         (sb-kernel-defstruct dd supers nil)
          ;; compiler stuff
          (sb-kernel::%compiler-defstruct dd supers) 
          ;; create make-?