From: Christophe Rhodes Date: Wed, 19 Jul 2006 18:30:27 +0000 (+0000) Subject: 0.9.14.25: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=603af6830a9c242adcec3fe3549e74e04cbe3228;p=sbcl.git 0.9.14.25: Fix bug (reported by Jasko on #lisp) regarding TYPEP on funcallable-standard-classes with accessors. ... make a STANDARD-CLASSOID for funcallable-standard-classes, too, as they behave (wrt the type system) in the same way. ... STD-CLASSOID is now useless; delete it. ... simplify MAKE-PRELIMINARY-LAYOUT a bit, since MAKE-WRAPPER now does the right thing. --- diff --git a/src/code/class.lisp b/src/code/class.lisp index dcd40fe..dc0b524 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -939,11 +939,15 @@ NIL is returned when no such class exists." ;;;; PCL stuff -(def!struct (std-classoid (:include classoid) - (:constructor nil))) -(def!struct (standard-classoid (:include std-classoid) +;;; the CLASSOID that we use to represent type information for +;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. The type system +;;; side does not need to distinguish between STANDARD-CLASS and +;;; FUNCALLABLE-STANDARD-CLASS. +(def!struct (standard-classoid (:include classoid) (:constructor make-standard-classoid))) -(def!struct (random-pcl-classoid (:include std-classoid) +;;; a metaclass for miscellaneous PCL structure-like objects (at the +;;; moment, only CTOR objects). +(def!struct (random-pcl-classoid (:include classoid) (:constructor make-random-pcl-classoid))) ;;;; built-in classes diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 7465081..cf62b49 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -258,6 +258,7 @@ (cond (owrap (layout-classoid owrap)) ((or (*subtypep (class-of class) *the-class-standard-class*) + (*subtypep (class-of class) *the-class-funcallable-standard-class*) (typep class 'forward-referenced-class)) (cond ((and *pcl-class-boot* (eq (slot-value class 'name) *pcl-class-boot*)) @@ -272,7 +273,7 @@ (make-standard-classoid :pcl-class class :name (and (symbolp name) name)))))) (t - (make-random-pcl-classoid :pcl-class class)))))) + (bug "Got to T branch in ~S" 'make-wrapper)))))) (t (let* ((found (find-classoid (slot-value class 'name))) (layout (classoid-layout found))) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index ed2d9b8..930dfd9 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -83,8 +83,8 @@ :slot-names (clos-slots name hash-code) :boa-constructor %make-pcl-funcallable-instance :superclass-name function - :metaclass-name random-pcl-classoid - :metaclass-constructor make-random-pcl-classoid + :metaclass-name standard-classoid + :metaclass-constructor make-standard-classoid :dd-type funcallable-structure ;; Only internal implementation code will access these, and these ;; accesses (slot readers in particular) could easily be a diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 553e17d..3acc5db 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -455,23 +455,14 @@ ;; some class is forthcoming, because there are legitimate ;; questions one can ask of the type system, implemented in ;; terms of CLASSOIDs, involving forward-referenced classes. So. - (let ((classoid (or (let ((layout (slot-value class 'wrapper))) - (when layout (layout-classoid layout))) - #+nil - (find-classoid name nil) - (make-standard-classoid - :name (if (symbolp name) name nil)))) - (layout (make-wrapper 0 class))) - (setf (layout-classoid layout) classoid) - (setf (classoid-pcl-class classoid) class) + (let ((layout (make-wrapper 0 class))) (setf (slot-value class 'wrapper) layout) (let ((cpl (compute-preliminary-cpl class))) (setf (layout-inherits layout) (order-layout-inherits (map 'simple-vector #'class-wrapper (reverse (rest cpl)))))) - (register-layout layout :invalidate t) - (setf (classoid-layout classoid) layout)))) + (register-layout layout :invalidate t)))) (mapc #'make-preliminary-layout (class-direct-subclasses class))))) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index b7af0cf..a2c85ef 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -489,15 +489,22 @@ ;;; classes (including anonymous ones) and eql-specializers should be ;;; allowed to be specializers. (defvar *anonymous-class* - (make-instance 'standard-class + (make-instance 'standard-class :direct-superclasses (list (find-class 'standard-object)))) (defvar *object-of-anonymous-class* (make-instance *anonymous-class*)) (eval `(defmethod method-on-anonymous-class ((obj ,*anonymous-class*)) 41)) (assert (eql (method-on-anonymous-class *object-of-anonymous-class*) 41)) -(eval `(defmethod method-on-anonymous-class - ((obj ,(intern-eql-specializer *object-of-anonymous-class*))) +(eval `(defmethod method-on-anonymous-class + ((obj ,(intern-eql-specializer *object-of-anonymous-class*))) 42)) (assert (eql (method-on-anonymous-class *object-of-anonymous-class*) 42)) +;;; accessors can cause early finalization, which caused confusion in +;;; the system, leading to uncompileable TYPEP problems. +(defclass funcallable-class-for-typep () + ((some-slot-with-accessor :accessor some-slot-with-accessor)) + (:metaclass funcallable-standard-class)) +(compile nil '(lambda (x) (typep x 'funcallable-class-for-typep))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 96a42df..e0713f0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.14.24" +"0.9.14.25"