On Sun, 2005-01-23 at 17:57 +0100, Sverker Wiberg wrote:
> Which is what the 'diff-2.txt' patch does. Now
> tests/mop-2.impure-cload.lisp succeeds.
>
> /Sverker
>
> P.S.
>
> As I noticed that the list server stripped my previous patch (but it got
> through on the news gateway), I'm including it again, as 'diff-1.txt'.
Not that it helped. So now I just paste the diffs into the mail ---
first diff-1.txt, then diff-2.txt.
/Sverker
=============== diff-1.txt
diff -x '*~' -Naur src.orig/pcl/info.lisp src/pcl/info.lisp
--- src.orig/pcl/info.lisp 2003-06-03 12:28:23.000000000 +0200
+++ src/pcl/info.lisp 2005-01-13 22:26:40.000000000 +0100
@@ -59,7 +59,7 @@
(name nil :type symbol)
;;
;; Specified slot allocation.or :INSTANCE.
- (allocation :instance :type (member :class :instance))
+ (allocation :instance :type (or (member :class :instance) t))
;;
;; Specified slot type or T.
(type t :type (or symbol list)))
diff -x '*~' -Naur src.orig/pcl/slots-boot.lisp src/pcl/slots-boot.lisp
--- src.orig/pcl/slots-boot.lisp 2003-06-17 15:16:45.000000000 +0200
+++ src/pcl/slots-boot.lisp 2005-01-14 00:41:56.000000000 +0100
@@ -198,7 +198,12 @@
(let ((value (cdr index)))
(if (eq value +slot-unbound+)
(values (slot-unbound (class-of instance) instance
slot-name))
- value)))))
+ value))))
+ (null (lambda (instance)
+ (check-obsolete-instance instance)
+ (error "~@<Slot ~S in class ~S ~
+ does not have standard allocation.~@:>"
+ slot-name (class-of instance)))))
`(reader ,slot-name)))
(defun make-optimized-std-writer-method-function (fsc-p slot-name
index)
@@ -214,7 +219,12 @@
(setf (%slot-ref (std-instance-slots instance) index) nv))))
(cons (lambda (nv instance)
(check-obsolete-instance instance)
- (setf (cdr index) nv))))
+ (setf (cdr index) nv)))
+ (null (lambda (instance)
+ (check-obsolete-instance instance)
+ (error "~@<Slot ~S in class ~S ~
+ does not have standard allocation.~@:>"
+ slot-name (class-of instance)))))
`(writer ,slot-name)))
(defun make-optimized-std-boundp-method-function (fsc-p slot-name
index)
@@ -232,7 +242,12 @@
+slot-unbound+)))))
(cons (lambda (instance)
(check-obsolete-instance instance)
- (not (eq (cdr index) +slot-unbound+)))))
+ (not (eq (cdr index) +slot-unbound+))))
+ (null (lambda (instance)
+ (check-obsolete-instance instance)
+ (error "~@<Slot ~S in class ~S ~
+ does not have standard allocation.~@:>"
+ slot-name (class-of instance)))))
`(boundp ,slot-name)))
(defun make-optimized-structure-slot-value-using-class-method-function
(function)
@@ -322,7 +337,13 @@
(let ((value (cdr index)))
(if (eq value +slot-unbound+)
(values (slot-unbound class instance slot-name))
- value))))))
+ value))))
+ (null (lambda (class instance slotd)
+ (declare (ignore slotd))
+ (check-obsolete-instance instance)
+ (error "~@<Slot ~S in class ~S ~
+ does not have standard allocation.~@:>"
+ slot-name class)))))
(defun make-optimized-std-setf-slot-value-using-class-method-function
(fsc-p slot-name index)
@@ -341,7 +362,13 @@
(cons (lambda (nv class instance slotd)
(declare (ignore class slotd))
(check-obsolete-instance instance)
- (setf (cdr index) nv)))))
+ (setf (cdr index) nv)))
+ (null (lambda (class instance slotd)
+ (declare (ignore slotd))
+ (check-obsolete-instance instance)
+ (error "~@<Slot ~S in class ~S ~
+ does not have standard allocation.~@:>"
+ slot-name class)))))
(defun make-optimized-std-slot-boundp-using-class-method-function
(fsc-p slot-name index)
@@ -362,7 +389,13 @@
(cons (lambda (class instance slotd)
(declare (ignore class slotd))
(check-obsolete-instance instance)
- (not (eq (cdr index) +slot-unbound+))))))
+ (not (eq (cdr index) +slot-unbound+))))
+ (null (lambda (class instance slotd)
+ (declare (ignore slotd))
+ (check-obsolete-instance instance)
+ (error "~@<Slot ~S in class ~S ~
+ does not have standard allocation.~@:>"
+ slot-name class)))))
(defun make-internal-reader-method-function (class-name slot-name)
(list* :method-spec `(internal-reader-method ,class-name ,slot-name)
diff -x '*~' -Naur src.orig/pcl/std-class.lisp src/pcl/std-class.lisp
--- src.orig/pcl/std-class.lisp 2004-07-16 16:06:24.000000000 +0200
+++ src/pcl/std-class.lisp 2005-01-13 23:01:56.000000000 +0100
@@ -867,7 +867,7 @@
(defun update-slots (class eslotds)
(collect ((instance-slots) (class-slots))
(dolist (eslotd eslotds)
- (ecase (slot-definition-allocation eslotd)
+ (case (slot-definition-allocation eslotd)
(:instance (instance-slots eslotd))
(:class (class-slots eslotd))))
;;
@@ -999,7 +999,7 @@
(loop with slotds = (call-next-method) and location = -1
for slot in slotds do
(setf (slot-definition-location slot)
- (ecase (slot-definition-allocation slot)
+ (case (slot-definition-allocation slot)
(:instance
(incf location))
(:class
@@ -1045,7 +1045,7 @@
(instance-slots ())
(class-slots ()))
(loop for slotd in all-slotds do
- (ecase (slot-definition-allocation slotd)
+ (case (slot-definition-allocation slotd)
(:instance (push slotd instance-slots))
(:class (push slotd class-slots))))
(loop with layout = (compute-layout instance-slots)
diff -x '*~' -Naur src.orig/tests/mop-1.impure-cload.lisp
src/tests/mop-1.impure-cload.lisp
--- src.orig/tests/mop-1.impure-cload.lisp 1970-01-01 01:00:00.000000000
+0100
+++ src/tests/mop-1.impure-cload.lisp 2005-01-17 23:36:05.000000000
+0100
@@ -0,0 +1,125 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;;; Note that the MOP is not in an entirely supported state.
+;;;; However, this seems a good a way as any of ensuring that we have
+;;;; no regressions.
+
+;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
+;;; fixups for running in the full MOP rather than closette: SLOTDs
+;;; instead of slot-names, and so on.
+
+(defpackage "TEST" (:use "CL" #+sbcl "SB-MOP" #+pcl "PCL"))
+(in-package "TEST")
+
+(defclass dynamic-slot-class (standard-class) ())
+
+(defmethod validate-superclass
+ ((class dynamic-slot-class) (super standard-class))
+ t)
+
+(defmethod compute-effective-slot-definition
+ ((class dynamic-slot-class) name direct-slots)
+ (let ((slot (call-next-method)))
+ (setf (slot-definition-allocation slot) :dynamic)
+ slot))
+
+(defun dynamic-slot-p (slot)
+ (eq (slot-definition-allocation slot) :dynamic))
+
+(let ((table (make-hash-table)))
+
+ (defun allocate-table-entry (instance)
+ (setf (gethash instance table) ()))
+
+ (defun read-dynamic-slot-value (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (if (null entry)
+ (error "slot ~S unbound in ~S" slot-name instance)
+ (cdr entry))))
+
+ (defun write-dynamic-slot-value (new-value instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (if (null entry)
+ (push `(,slot-name . ,new-value)
+ (gethash instance table))
+ (setf (cdr entry) new-value))
+ new-value))
+
+ (defun dynamic-slot-boundp (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (not (null entry))))
+
+ (defun dynamic-slot-makunbound (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (unless (null entry)
+ (setf (gethash instance table) (delete entry alist))))
+ instance)
+
+)
+
+(defmethod allocate-instance ((class dynamic-slot-class) &key)
+ (let ((instance (call-next-method)))
+ (allocate-table-entry instance)
+ instance))
+
+(defmethod slot-value-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if slot
+ (read-dynamic-slot-value instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defmethod (setf slot-value-using-class) (new-value (class
dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if slot
+ (write-dynamic-slot-value new-value instance (slot-definition-name
slotd))
+ (call-next-method))))
+
+(defmethod slot-boundp-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if slot
+ (dynamic-slot-boundp instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defmethod slot-makunbound-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if slot
+ (dynamic-slot-makunbound instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defclass test-class-1 ()
+ ((slot1 :initarg :slot1)
+ (slot2 :initarg :slot2 :initform nil))
+ (:metaclass dynamic-slot-class))
+
+(defclass test-class-2 (test-class-1)
+ ((slot2 :initarg :slot2 :initform t)
+ (slot3 :initarg :slot3))
+ (:metaclass dynamic-slot-class))
+
+(defvar *one* (make-instance 'test-class-1))
+(defvar *two* (make-instance 'test-class-2 :slot3 1))
+
+(assert (not (slot-boundp *one* 'slot1)))
+(assert (null (slot-value *one* 'slot2)))
+(assert (eq t (slot-value *two* 'slot2)))
+(assert (= 1 (slot-value *two* 'slot3)))
+
diff -x '*~' -Naur src.orig/tests/mop-2.impure-cload.lisp
src/tests/mop-2.impure-cload.lisp
--- src.orig/tests/mop-2.impure-cload.lisp 1970-01-01 01:00:00.000000000
+0100
+++ src/tests/mop-2.impure-cload.lisp 2005-01-17 23:37:33.000000000
+0100
@@ -0,0 +1,162 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;;; Note that the MOP is not in an entirely supported state.
+;;;; However, this seems a good a way as any of ensuring that we have
+;;;; no regressions.
+
+;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
+;;; fixups for running in the full MOP rather than closette -- SLOTDs
+;;; instead of slot-names, and so on -- and :allocation :dynamic for
+;;; dynamic slots.
+
+(untrace)
+
+(defpackage "TEST" (:use "CL" #+sbcl "SB-MOP" #+pcl "PCL"))
+(in-package "TEST")
+
+(defclass dynamic-slot-class (standard-class) ())
+
+(defmethod validate-superclass
+ ((class dynamic-slot-class) (super standard-class))
+ t)
+
+(defun dynamic-slot-p (slot)
+ (eq (slot-definition-allocation slot) :dynamic))
+
+(let ((table (make-hash-table)))
+
+ (defun allocate-table-entry (instance)
+ (setf (gethash instance table) ()))
+
+ (defun read-dynamic-slot-value (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (if (null entry)
+ (error "slot ~S unbound in ~S" slot-name instance)
+ (cdr entry))))
+
+ (defun write-dynamic-slot-value (new-value instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (if (null entry)
+ (push `(,slot-name . ,new-value)
+ (gethash instance table))
+ (setf (cdr entry) new-value))
+ new-value))
+
+ (defun dynamic-slot-boundp (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (not (null entry))))
+
+ (defun dynamic-slot-makunbound (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (unless (null entry)
+ (setf (gethash instance table) (delete entry alist))))
+ instance)
+
+)
+
+(defmethod allocate-instance ((class dynamic-slot-class) &key)
+ (let ((instance (call-next-method)))
+ (allocate-table-entry instance)
+ instance))
+
+(defmethod slot-value-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if (and slot (dynamic-slot-p slot))
+ (read-dynamic-slot-value instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defmethod (setf slot-value-using-class) (new-value (class
dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if (and slot (dynamic-slot-p slot))
+ (write-dynamic-slot-value new-value instance (slot-definition-name
slotd))
+ (call-next-method))))
+
+(defmethod slot-boundp-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if (and slot (dynamic-slot-p slot))
+ (dynamic-slot-boundp instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defmethod slot-makunbound-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if (and slot (dynamic-slot-p slot))
+ (dynamic-slot-makunbound instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defclass test-class-1 ()
+ ((slot1 :initarg :slot1 :allocation :dynamic)
+ (slot2 :initarg :slot2 :initform nil))
+ (:metaclass dynamic-slot-class))
+
+(defclass test-class-2 (test-class-1)
+ ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
+ (slot3 :initarg :slot3))
+ (:metaclass dynamic-slot-class))
+
+(defvar *one* (make-instance 'test-class-1))
+(defvar *two* (make-instance 'test-class-2 :slot3 1))
+
+(assert (not (slot-boundp *one* 'slot1)))
+(assert (null (slot-value *one* 'slot2)))
+(assert (eq t (slot-value *two* 'slot2)))
+(assert (= 1 (slot-value *two* 'slot3)))
+
+;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
+;;; overconservatism in accessing a class's precedence list deep in
+;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
+;;; finalizing a class.
+
+(defclass dynamic-slot-subclass (dynamic-slot-class) ())
+
+(defmethod slot-value-using-class ((class dynamic-slot-subclass)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if (and slot (dynamic-slot-p slot))
+ (read-dynamic-slot-value instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defmethod (setf slot-value-using-class) (new-value
+ (class dynamic-slot-subclass)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if (and slot (dynamic-slot-p slot))
+ (write-dynamic-slot-value new-value instance (slot-definition-name
slotd))
+ (call-next-method))))
+
+(defmethod slot-boundp-using-class ((class dynamic-slot-subclass)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if (and slot (dynamic-slot-p slot))
+ (dynamic-slot-boundp instance (slot-definition-name slotd))
+ (call-next-method))))
+
+#+#:never (defclass test-class-3 (test-class-1)
+ ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
+ (slot3 :initarg :slot3))
+ (:metaclass dynamic-slot-subclass))
+
+#|
+(defvar *three* (make-instance 'test-class-3 :slot3 3))
+(assert (not (slot-boundp *three* 'slot1)))
+(assert (eq (slot-value *three* 'slot2) t))
+(assert (= (slot-value *three* 'slot3) 3))
+|#
=============== diff-2.txt
diff -x '*~' -Naurb src-1/pcl/dfun.lisp src/pcl/dfun.lisp
--- src-1/pcl/dfun.lisp 2003-08-27 11:02:00.000000000 +0200
+++ src/pcl/dfun.lisp 2005-01-23 17:29:49.000000000 +0100
@@ -1613,7 +1613,7 @@
(case (car ntype)
(class
(let* ((class (type-class specl))
- (cpl (cpl-or-nil class)))
+ (cpl (cpl-maybe-early class)))
(not (memq (cadr ntype) cpl))))
(class-eq
(let ((class (case (car specl)
@@ -1626,7 +1626,7 @@
(class-eq (cadr specl))
(prototype (cadr specl))
(class (cadr specl))))
- (cpl (cpl-or-nil class)))
+ (cpl (cpl-maybe-early class)))
(not (memq (cadr ntype) cpl))))
(eql
(case (car specl)
@@ -1640,7 +1640,7 @@
(if (eq 'class (car specl))
(let* ((specl (cadr specl))
(type (cadr type))
- (cpl (cpl-or-nil type))
+ (cpl (cpl-maybe-early type))
(pred (memq specl cpl)))
(values pred
(or pred
@@ -1651,7 +1651,7 @@
(classes-have-common-subclass-p specl type)))))
(values nil
(let* ((class (type-class specl))
- (cpl (cpl-or-nil class)))
+ (cpl (cpl-maybe-early class)))
(memq (cadr type) cpl)))))
(defun classes-have-common-subclass-p (class1 class2)
@@ -1671,7 +1671,7 @@
(class
(or (eq (cadr specl) (cadr type))
(memq (cadr specl)
- (cpl-or-nil (cadr type))))))))
+ (cpl-maybe-early (cadr type))))))))
(values pred pred))))
(defun saut-prototype (specl type)
@@ -1686,7 +1686,7 @@
(eq (cadr specl) (class-of (cadr type))))
(class
(memq (cadr specl)
- (cpl-or-nil (class-of (cadr type))))))))
+ (cpl-maybe-early (class-of (cadr type))))))))
(values pred pred)))
diff -x '*~' -Naurb src-1/tests/mop-2.impure-cload.lisp
src/tests/mop-2.impure-cload.lisp
--- src-1/tests/mop-2.impure-cload.lisp 2005-01-17 23:37:33.000000000
+0100
+++ src/tests/mop-2.impure-cload.lisp 2005-01-23 17:31:13.000000000
+0100
@@ -149,14 +149,12 @@
(dynamic-slot-boundp instance (slot-definition-name slotd))
(call-next-method))))
-#+#:never (defclass test-class-3 (test-class-1)
+(defclass test-class-3 (test-class-1)
((slot2 :initarg :slot2 :initform t :allocation :dynamic)
(slot3 :initarg :slot3))
(:metaclass dynamic-slot-subclass))
-#|
(defvar *three* (make-instance 'test-class-3 :slot3 3))
(assert (not (slot-boundp *three* 'slot1)))
(assert (eq (slot-value *three* 'slot2) t))
(assert (= (slot-value *three* 'slot3) 3))
-|#
===============
