[Sbcl-commits] CVS: sbcl/src/pcl defs.lisp, 1.68, 1.69 fixup.lisp, 1.9, 1.10 std-class.lisp, 1.124, 1.125

[<no...@so...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv21310/src/pcl

Modified Files:
	defs.lisp fixup.lisp std-class.lisp 
Log Message:
1.0.21.1: address TYPE-WARNING in CLOS allocator for funcallable structures
	... parallel %make-funcallable-structure-allocator;
	... make FUNCTION-classoid-subclasses into CLOS classes in FIXUP
	... also make !DEFSTRUCT-W-A-M respect *DEFSTRUCT-HOOKS* just
		in case.
	... test.


Index: defs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v
retrieving revision 1.68
retrieving revision 1.69
diff -u -d -r1.68 -r1.69
--- defs.lisp	23 Sep 2008 22:06:05 -0000	1.68
+++ defs.lisp	3 Oct 2008 12:21:10 -0000	1.69
@@ -680,15 +680,9 @@
 (defclass condition-class (slot-class) ())
 
 (defclass structure-class (slot-class)
-  ((defstruct-form
-     :initform ()
-     :accessor class-defstruct-form)
-   (defstruct-constructor
-     :initform nil
-     :accessor class-defstruct-constructor)
-   (from-defclass-p
-    :initform nil
-    :initarg :from-defclass-p)))
+  ((defstruct-form :initform () :accessor class-defstruct-form)
+   (defstruct-constructor :initform nil :accessor class-defstruct-constructor)
+   (from-defclass-p :initform nil :initarg :from-defclass-p)))
 
 (defclass definition-source-mixin (standard-object)
   ((source

Index: fixup.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/fixup.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- fixup.lisp	12 Nov 2007 17:14:51 -0000	1.9
+++ fixup.lisp	3 Oct 2008 12:21:10 -0000	1.10
@@ -26,7 +26,7 @@
 (!fix-early-generic-functions)
 (!fix-ensure-accessor-specializers)
 (compute-standard-slot-locations)
-(dolist (s '(condition structure-object))
+(dolist (s '(condition function structure-object))
   (dohash ((k v) (classoid-subclasses (find-classoid s)))
     (find-class (classoid-name k))))
 (setq *boot-state* 'complete)
@@ -34,4 +34,3 @@
 (defun print-std-instance (instance stream depth)
   (declare (ignore depth))
   (print-object instance stream))
-

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.124
retrieving revision 1.125
diff -u -d -r1.124 -r1.125
--- std-class.lisp	9 Jun 2008 21:49:15 -0000	1.124
+++ std-class.lisp	3 Oct 2008 12:21:10 -0000	1.125
@@ -658,7 +658,11 @@
 (defun make-defstruct-allocation-function (name)
   ;; FIXME: Why don't we go class->layout->info == dd
   (let ((dd (find-defstruct-description name)))
-    (%make-structure-instance-allocator dd nil)))
+    (ecase (dd-type dd)
+      (structure
+       (%make-structure-instance-allocator dd nil))
+      (funcallable-structure
+       (%make-funcallable-structure-instance-allocator dd nil)))))
 
 (defmethod shared-initialize :after
     ((class structure-class) slot-names &key