From: Christophe R. <cr...@us...> - 2003-03-20 16:04:00
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1:/tmp/cvs-serv16556/src/pcl Modified Files: Tag: pcl_class_defrobulation_branch braid.lisp cache.lisp ctor.lisp defclass.lisp defs.lisp documentation.lisp early-low.lisp env.lisp low.lisp macros.lisp methods.lisp print-object.lisp std-class.lisp Log Message: 0.7.13.pcl-class.1 Turn SB-PCL::CLASS into CL:CLASS ... and to do that, turn CL:CLASS into SB-KERNEL:CLASSOID Well, there's a little more to it than that. This commit causes no regressions against our own test suite (once the necessary s/SB-PCL:FIND-CLASS/FIND-CLASS/ changes have been made) but, along with several new passes in the gcl suite, causes one new failure to do with condition classes. There have been some code deletions, too, as some methods that were necessary to paper over the cracks between the two different CLASSes are now no longer necessary, as the CLASSOID structure is now viewed as internal. The major code addition is probably SB-PCL::SET-CLASS-TYPE-TRANSLATOR, which communicates the necessary information to the type engine (with extra hair to get BUILT-IN-CLASSES right). This branch is expected to last during the freeze period, and land shortly after 0.7.14 is released. Index: braid.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v retrieving revision 1.29 retrieving revision 1.29.4.1 diff -u -d -r1.29 -r1.29.4.1 --- braid.lisp 19 Feb 2003 17:11:39 -0000 1.29 +++ braid.lisp 20 Mar 2003 16:03:52 -0000 1.29.4.1 @@ -146,7 +146,7 @@ (built-in-class built-in-class-wrapper) (structure-class structure-class-wrapper))) (class (or (find-class name nil) - (allocate-standard-instance wrapper)))) + (allocate-standard-instance wrapper)))) (setf (find-class name) class))) (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) @@ -493,11 +493,11 @@ (dolist (e *built-in-classes*) (destructuring-bind (name supers subs cpl prototype) e (let* ((class (find-class name)) - (lclass (cl:find-class name)) - (wrapper (sb-kernel:class-layout lclass))) + (lclass (sb-kernel:find-classoid name)) + (wrapper (sb-kernel:classoid-layout lclass))) (set (get-built-in-class-symbol name) class) (set (get-built-in-wrapper-symbol name) wrapper) - (setf (sb-kernel:class-pcl-class lclass) class) + (setf (sb-kernel:classoid-pcl-class lclass) class) (!bootstrap-initialize-class 'built-in-class class name class-eq-wrapper nil @@ -544,9 +544,9 @@ :metaclass 'structure-class :name symbol :direct-superclasses - (mapcar #'cl:class-name - (sb-kernel:class-direct-superclasses - (cl:find-class symbol))) + (mapcar #'sb-kernel:classoid-name + (sb-kernel:classoid-direct-superclasses + (sb-kernel:find-classoid symbol))) :direct-slots (mapcar #'slot-initargs-from-structure-slotd (structure-type-slot-description-list @@ -589,8 +589,8 @@ ;;; Set the inherits from CPL, and register the layout. This actually ;;; installs the class in the Lisp type system. (defun update-lisp-class-layout (class layout) - (let ((lclass (sb-kernel:layout-class layout))) - (unless (eq (sb-kernel:class-layout lclass) layout) + (let ((lclass (sb-kernel:layout-classoid layout))) + (unless (eq (sb-kernel:classoid-layout lclass) layout) (setf (sb-kernel:layout-inherits layout) (sb-kernel:order-layout-inherits (map 'simple-vector #'class-wrapper @@ -601,15 +601,26 @@ ;; unknown to CL:FIND-CLASS and also anonymous. This ;; functionality moved here from (SETF FIND-CLASS). (let ((name (class-name class))) - (setf (cl:find-class name) lclass - ;; FIXME: It's nasty to use double colons. Perhaps the - ;; best way to fix this is not to export CLASS-%NAME - ;; from SB-KERNEL, but instead to move the whole - ;; UPDATE-LISP-CLASS-LAYOUT function to SB-KERNEL, and - ;; export it. (since it's also nasty for us to be - ;; reaching into %KERNEL implementation details my - ;; messing with raw CLASS-%NAME) - (sb-kernel::class-%name lclass) name))))) + (setf (sb-kernel:find-classoid name) lclass + (sb-kernel:classoid-name lclass) name))))) + +(defun set-class-type-translation (class name) + (let ((classoid (sb-kernel:find-classoid name nil))) + (etypecase classoid + (null) + (sb-kernel:built-in-classoid + (let ((translation (sb-kernel::built-in-classoid-translation classoid))) + (cond + (translation + (aver (sb-kernel:ctype-p translation)) + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) translation))) + (t + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid)))))) + (sb-kernel:classoid + (setf (info :type :translator class) + (lambda (spec) (declare (ignore spec)) classoid)))))) (clrhash *find-class*) (!bootstrap-meta-braid) @@ -622,19 +633,21 @@ (dohash (name x *find-class*) (let* ((class (find-class-from-cell name x)) (layout (class-wrapper class)) - (lclass (sb-kernel:layout-class layout)) - (lclass-pcl-class (sb-kernel:class-pcl-class lclass)) - (olclass (cl:find-class name nil))) + (lclass (sb-kernel:layout-classoid layout)) + (lclass-pcl-class (sb-kernel:classoid-pcl-class lclass)) + (olclass (sb-kernel:find-classoid name nil))) (if lclass-pcl-class (aver (eq class lclass-pcl-class)) - (setf (sb-kernel:class-pcl-class lclass) class)) + (setf (sb-kernel:classoid-pcl-class lclass) class)) (update-lisp-class-layout class layout) (cond (olclass (aver (eq lclass olclass))) (t - (setf (cl:find-class name) lclass))))) + (setf (sb-kernel:find-classoid name) lclass))) + + (set-class-type-translation class name))) (setq *boot-state* 'braid) Index: cache.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/cache.lisp,v retrieving revision 1.26 retrieving revision 1.26.12.1 diff -u -d -r1.26 -r1.26.12.1 --- cache.lisp 29 Oct 2002 12:48:21 -0000 1.26 +++ cache.lisp 20 Mar 2003 16:03:53 -0000 1.26.12.1 @@ -257,7 +257,7 @@ (setq *the-class-t* nil)) (defmacro wrapper-class (wrapper) - `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper))) + `(sb-kernel:classoid-pcl-class (sb-kernel:layout-classoid ,wrapper))) (defmacro wrapper-no-of-instance-slots (wrapper) `(sb-kernel:layout-length ,wrapper)) @@ -271,19 +271,20 @@ ;;; whose slots are not initialized yet, and which may be built-in ;;; classes. We pass in the class name in addition to the class. (defun boot-make-wrapper (length name &optional class) - (let ((found (cl:find-class name nil))) + (let ((found (sb-kernel:find-classoid name nil))) (cond (found - (unless (sb-kernel:class-pcl-class found) - (setf (sb-kernel:class-pcl-class found) class)) - (aver (eq (sb-kernel:class-pcl-class found) class)) - (let ((layout (sb-kernel:class-layout found))) + (unless (sb-kernel:classoid-pcl-class found) + (setf (sb-kernel:classoid-pcl-class found) class)) + (aver (eq (sb-kernel:classoid-pcl-class found) class)) + (let ((layout (sb-kernel:classoid-layout found))) (aver layout) layout)) (t (make-wrapper-internal :length length - :class (sb-kernel:make-standard-class :name name :pcl-class class)))))) + :classoid (sb-kernel:make-standard-classoid + :name name :pcl-class class)))))) ;;; The following variable may be set to a STANDARD-CLASS that has ;;; already been created by the lisp code and which is to be redefined @@ -294,35 +295,36 @@ ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in ;;; and structure classes already exist when PCL is initialized, so we ;;; don't necessarily always make a wrapper. Also, we help maintain -;;; the mapping between CL:CLASS and PCL::CLASS objects. +;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects. (defun make-wrapper (length class) (cond ((typep class 'std-class) (make-wrapper-internal :length length - :class + :classoid (let ((owrap (class-wrapper class))) (cond (owrap - (sb-kernel:layout-class owrap)) + (sb-kernel:layout-classoid owrap)) ((*subtypep (class-of class) *the-class-standard-class*) (cond ((and *pcl-class-boot* (eq (slot-value class 'name) *pcl-class-boot*)) - (let ((found (cl:find-class (slot-value class 'name)))) - (unless (sb-kernel:class-pcl-class found) - (setf (sb-kernel:class-pcl-class found) class)) - (aver (eq (sb-kernel:class-pcl-class found) class)) + (let ((found (sb-kernel:find-classoid + (slot-value class 'name)))) + (unless (sb-kernel:classoid-pcl-class found) + (setf (sb-kernel:classoid-pcl-class found) class)) + (aver (eq (sb-kernel:classoid-pcl-class found) class)) found)) (t - (sb-kernel:make-standard-class :pcl-class class)))) + (sb-kernel:make-standard-classoid :pcl-class class)))) (t - (sb-kernel:make-random-pcl-class :pcl-class class)))))) + (sb-kernel:make-random-pcl-classoid :pcl-class class)))))) (t - (let* ((found (cl:find-class (slot-value class 'name))) - (layout (sb-kernel:class-layout found))) - (unless (sb-kernel:class-pcl-class found) - (setf (sb-kernel:class-pcl-class found) class)) - (aver (eq (sb-kernel:class-pcl-class found) class)) + (let* ((found (sb-kernel:find-classoid (slot-value class 'name))) + (layout (sb-kernel:classoid-layout found))) + (unless (sb-kernel:classoid-pcl-class found) + (setf (sb-kernel:classoid-pcl-class found) class)) + (aver (eq (sb-kernel:classoid-pcl-class found) class)) (aver layout) layout)))) @@ -356,7 +358,7 @@ (defun wrapper-class* (wrapper) (or (wrapper-class wrapper) (find-structure-class - (cl:class-name (sb-kernel:layout-class wrapper))))) + (sb-kernel:classoid-name (sb-kernel:layout-classoid wrapper))))) ;;; The wrapper cache machinery provides general mechanism for ;;; trapping on the next access to any instance of a given class. This Index: ctor.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/ctor.lisp,v retrieving revision 1.2 retrieving revision 1.2.8.1 diff -u -d -r1.2 -r1.2.8.1 --- ctor.lisp 30 Dec 2002 00:42:27 -0000 1.2 +++ ctor.lisp 20 Mar 2003 16:03:53 -0000 1.2.8.1 @@ -96,8 +96,8 @@ :slot-names (function-name class-name class initargs) :boa-constructor %make-ctor :superclass-name pcl-funcallable-instance - :metaclass-name sb-kernel:random-pcl-class - :metaclass-constructor sb-kernel:make-random-pcl-class + :metaclass-name sb-kernel:random-pcl-classoid + :metaclass-constructor sb-kernel:make-random-pcl-classoid :dd-type sb-kernel:funcallable-structure :runtime-type-checks-p nil) Index: defclass.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/defclass.lisp,v retrieving revision 1.25 retrieving revision 1.25.4.1 diff -u -d -r1.25 -r1.25.4.1 --- defclass.lisp 15 Feb 2003 11:16:34 -0000 1.25 +++ defclass.lisp 20 Mar 2003 16:03:53 -0000 1.25.4.1 @@ -72,11 +72,7 @@ (error "The value of the :metaclass option (~S) is not a~%~ legal class name." (cadr option))) - (setq metaclass - (case (cadr option) - (cl:standard-class 'standard-class) - (cl:structure-class 'structure-class) - (t (cadr option)))) + (setq metaclass (cadr option)) (setf options (remove option options)) (return t)))) Index: defs.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v retrieving revision 1.26 retrieving revision 1.26.6.1 diff -u -d -r1.26 -r1.26.6.1 --- defs.lisp 31 Jan 2003 09:28:36 -0000 1.26 +++ defs.lisp 20 Mar 2003 16:03:53 -0000 1.26.6.1 @@ -148,9 +148,10 @@ :object (coerce-to-class (car args)))) (class-eq (class-eq-specializer (coerce-to-class (car args)))) (eql (intern-eql-specializer (car args)))))) - ((and (null args) (typep type 'cl:class)) - (or (sb-kernel:class-pcl-class type) - (find-structure-class (cl:class-name type)))) + ;; FIXME: do we still need this? + ((and (null args) (typep type 'sb-kernel:classoid)) + (or (sb-kernel:classoid-pcl-class type) + (find-structure-class (sb-kernel:classoid-name type)))) ((specializerp type) type))) ;;; interface @@ -216,7 +217,7 @@ ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type)))) ((class class-eq) ; class-eq is impossible to do right - (sb-kernel:layout-class (class-wrapper (cadr type)))) + (sb-kernel:layout-classoid (class-wrapper (cadr type)))) (eql type) (t (if (null (cdr type)) (car type) @@ -358,16 +359,16 @@ (defvar *built-in-classes* (labels ((direct-supers (class) (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class)) - (if (typep class 'cl:built-in-class) - (sb-kernel:built-in-class-direct-superclasses class) + (if (typep class 'sb-kernel:built-in-classoid) + (sb-kernel:built-in-classoid-direct-superclasses class) (let ((inherits (sb-kernel:layout-inherits - (sb-kernel:class-layout class)))) + (sb-kernel:classoid-layout class)))) (/noshow inherits) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class)) (collect ((res)) - (let ((subs (sb-kernel:class-subclasses class))) + (let ((subs (sb-kernel:classoid-subclasses class))) (/noshow subs) (when subs (dohash (sub v subs) @@ -402,17 +403,18 @@ (mapcar (lambda (kernel-bic-entry) (/noshow "setting up" kernel-bic-entry) (let* ((name (car kernel-bic-entry)) - (class (cl:find-class name))) + (class (sb-kernel:find-classoid name))) (/noshow name class) `(,name - ,(mapcar #'cl:class-name (direct-supers class)) - ,(mapcar #'cl:class-name (direct-subs class)) + ,(mapcar #'sb-kernel:classoid-name (direct-supers class)) + ,(mapcar #'sb-kernel:classoid-name (direct-subs class)) ,(map 'list (lambda (x) - (cl:class-name (sb-kernel:layout-class x))) + (sb-kernel:classoid-name + (sb-kernel:layout-classoid x))) (reverse (sb-kernel:layout-inherits - (sb-kernel:class-layout class)))) + (sb-kernel:classoid-layout class)))) ,(prototype name)))) (remove-if (lambda (kernel-bic-entry) (member (first kernel-bic-entry) Index: documentation.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/documentation.lisp,v retrieving revision 1.7 retrieving revision 1.7.4.1 diff -u -d -r1.7 -r1.7.4.1 --- documentation.lisp 19 Feb 2003 17:11:39 -0000 1.7 +++ documentation.lisp 20 Mar 2003 16:03:54 -0000 1.7.4.1 @@ -68,28 +68,12 @@ ;;; other code which does low-level hacking of packages.. -- WHN 19991203 ;;; types, classes, and structure names -(defmethod documentation ((x cl:structure-class) (doc-type (eql 't))) - (values (info :type :documentation (cl:class-name x)))) - (defmethod documentation ((x structure-class) (doc-type (eql 't))) (values (info :type :documentation (class-name x)))) -(defmethod documentation ((x cl:standard-class) (doc-type (eql 't))) - (or (values (info :type :documentation (cl:class-name x))) - (let ((pcl-class (sb-kernel:class-pcl-class x))) - (and pcl-class (plist-value pcl-class 'documentation))))) - -(defmethod documentation ((x cl:structure-class) (doc-type (eql 'type))) - (values (info :type :documentation (cl:class-name x)))) - (defmethod documentation ((x structure-class) (doc-type (eql 'type))) (values (info :type :documentation (class-name x)))) -(defmethod documentation ((x cl:standard-class) (doc-type (eql 'type))) - (or (values (info :type :documentation (cl:class-name x))) - (let ((pcl-class (sb-kernel:class-pcl-class x))) - (and pcl-class (plist-value pcl-class 'documentation))))) - (defmethod documentation ((x symbol) (doc-type (eql 'type))) (or (values (info :type :documentation x)) (let ((class (find-class x nil))) @@ -101,19 +85,9 @@ (values (info :type :documentation x)))) (defmethod (setf documentation) (new-value - (x cl:structure-class) - (doc-type (eql 't))) - (setf (info :type :documentation (cl:class-name x)) new-value)) - -(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't))) (setf (info :type :documentation (class-name x)) new-value)) - -(defmethod (setf documentation) (new-value - (x cl:structure-class) - (doc-type (eql 'type))) - (setf (info :type :documentation (cl:class-name x)) new-value)) (defmethod (setf documentation) (new-value (x structure-class) Index: early-low.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/early-low.lisp,v retrieving revision 1.5 retrieving revision 1.5.4.1 diff -u -d -r1.5 -r1.5.4.1 --- early-low.lisp 15 Feb 2003 11:16:34 -0000 1.5 +++ early-low.lisp 20 Mar 2003 16:03:54 -0000 1.5.4.1 @@ -53,9 +53,10 @@ ;;; it needs a more mnemonic name. -- WHN 19991204 (defun structure-type-p (type) (and (symbolp type) - (let ((class (cl:find-class type nil))) - (and class - (typep (sb-kernel:layout-info (sb-kernel:class-layout class)) + (let ((classoid (sb-kernel:find-classoid type nil))) + (and classoid + (typep (sb-kernel:layout-info + (sb-kernel:classoid-layout classoid)) 'sb-kernel:defstruct-description))))) (/show "finished with early-low.lisp") Index: env.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/env.lisp,v retrieving revision 1.8 retrieving revision 1.8.16.1 diff -u -d -r1.8 -r1.8.16.1 --- env.lisp 6 Jun 2002 12:32:13 -0000 1.8 +++ env.lisp 20 Mar 2003 16:03:54 -0000 1.8.16.1 @@ -125,40 +125,10 @@ (defmethod make-load-form ((object wrapper) &optional env) (declare (ignore env)) - (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object)))) + (let ((pname (sb-kernel:classoid-proper-name + (sb-kernel:layout-classoid object)))) (unless pname (error "can't dump wrapper for anonymous class:~% ~S" - (sb-kernel:layout-class object))) - `(sb-kernel:class-layout (cl:find-class ',pname)))) - -;;;; The following are hacks to deal with CMU CL having two different CLASS -;;;; classes. - -(defun coerce-to-pcl-class (class) - (if (typep class 'cl:class) - (or (sb-kernel:class-pcl-class class) - (find-structure-class (cl:class-name class))) - class)) - -(defmethod make-instance ((class cl:class) &rest stuff) - (apply #'make-instance (coerce-to-pcl-class class) stuff)) -(defmethod change-class (instance (class cl:class) &rest initargs) - (apply #'change-class instance (coerce-to-pcl-class class) initargs)) + (sb-kernel:layout-classoid object))) + `(sb-kernel:classoid-layout (sb-kernel:find-classoid ',pname)))) -(macrolet ((frob (&rest names) - `(progn - ,@(mapcar (lambda (name) - `(defmethod ,name ((class cl:class)) - (funcall #',name - (coerce-to-pcl-class class)))) - names)))) - (frob - class-direct-slots - class-prototype - class-precedence-list - class-direct-default-initargs - class-direct-superclasses - compute-class-precedence-list - class-default-initargs class-finalized-p - class-direct-subclasses class-slots - make-instances-obsolete)) Index: low.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/low.lisp,v retrieving revision 1.27 retrieving revision 1.27.6.1 diff -u -d -r1.27 -r1.27.6.1 --- low.lisp 25 Jan 2003 19:30:17 -0000 1.27 +++ low.lisp 20 Mar 2003 16:03:54 -0000 1.27.6.1 @@ -83,8 +83,8 @@ :slot-names (clos-slots name hash-code) :boa-constructor %make-pcl-funcallable-instance :superclass-name sb-kernel:funcallable-instance - :metaclass-name sb-kernel:random-pcl-class - :metaclass-constructor sb-kernel:make-random-pcl-class + :metaclass-name sb-kernel:random-pcl-classoid + :metaclass-constructor sb-kernel:make-random-pcl-classoid :dd-type sb-kernel:funcallable-structure ;; Only internal implementation code will access these, and these ;; accesses (slot readers in particular) could easily be a @@ -257,8 +257,8 @@ :slot-names (slots hash-code) :boa-constructor %make-standard-instance :superclass-name sb-kernel:instance - :metaclass-name cl:standard-class - :metaclass-constructor sb-kernel:make-standard-class + :metaclass-name sb-kernel:standard-classoid + :metaclass-constructor sb-kernel:make-standard-classoid :dd-type structure :runtime-type-checks-p nil) @@ -328,7 +328,8 @@ ;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp. (defun get-structure-dd (type) - (sb-kernel:layout-info (sb-kernel:class-layout (cl:find-class type)))) + (sb-kernel:layout-info (sb-kernel:classoid-layout + (sb-kernel:find-classoid type)))) (defun structure-type-included-type-name (type) (let ((include (sb-kernel::dd-include (get-structure-dd type)))) Index: macros.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/macros.lisp,v retrieving revision 1.19 retrieving revision 1.19.10.1 diff -u -d -r1.19 -r1.19.10.1 --- macros.lisp 23 Dec 2002 13:53:00 -0000 1.19 +++ macros.lisp 20 Mar 2003 16:03:54 -0000 1.19.10.1 @@ -75,9 +75,7 @@ ;;;; FIND-CLASS ;;;; -;;;; This is documented in the CLOS specification. FIXME: Except that -;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from -;;;; PCL:FIND-CLASS, alas. +;;;; This is documented in the CLOS specification. (/show "pcl/macros.lisp 119") @@ -124,8 +122,7 @@ (find-class-cell-predicate cell)) (defun legal-class-name-p (x) - (and (symbolp x) - (not (keywordp x)))) + (symbolp x)) (defun find-class (symbol &optional (errorp t) environment) (declare (ignore environment)) @@ -149,9 +146,6 @@ (/show "pcl/macros.lisp 187") -;;; Note that in SBCL as in CMU CL, -;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS. -;;; (Yes, this is a KLUDGE!) (define-compiler-macro find-class (&whole form symbol &optional (errorp t) environment) (declare (ignore environment)) @@ -166,8 +160,8 @@ (or (find-class-cell-class ,class-cell) ,(if errorp `(find-class-from-cell ',symbol ,class-cell t) - `(and (sb-kernel:class-cell-class - ',(sb-kernel:find-class-cell symbol)) + `(and (sb-kernel:classoid-cell-classoid + ',(sb-kernel:find-classoid-cell symbol)) (find-class-from-cell ',symbol ,class-cell nil)))))) form)) Index: methods.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v retrieving revision 1.19 retrieving revision 1.19.10.1 diff -u -d -r1.19 -r1.19.10.1 --- methods.lisp 23 Dec 2002 13:53:00 -0000 1.19 +++ methods.lisp 20 Mar 2003 16:03:54 -0000 1.19.10.1 @@ -929,7 +929,8 @@ (cond ((eq class *the-class-t*) t) ((eq class *the-class-slot-object*) - `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class))) + `(not (typep (sb-kernel:classoid-of ,arg) + 'sb-kernel:built-in-classoid))) ((eq class *the-class-std-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) ((eq class *the-class-standard-object*) Index: print-object.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/print-object.lisp,v retrieving revision 1.7 retrieving revision 1.7.16.1 diff -u -d -r1.7 -r1.7.16.1 --- print-object.lisp 27 Dec 2001 17:17:54 -0000 1.7 +++ print-object.lisp 20 Mar 2003 16:03:54 -0000 1.7.16.1 @@ -98,7 +98,7 @@ (defun named-object-print-function (instance stream &optional (extra nil extra-p)) - (print-unreadable-object (instance stream :type t) + (print-unreadable-object (instance stream :type t :identity t) (if extra-p (format stream "~S ~:S" Index: std-class.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v retrieving revision 1.37 retrieving revision 1.37.4.1 diff -u -d -r1.37 -r1.37.4.1 --- std-class.lisp 15 Feb 2003 11:16:35 -0000 1.37 +++ std-class.lisp 20 Mar 2003 16:03:55 -0000 1.37.4.1 @@ -322,11 +322,7 @@ :definition-source `((defclass ,name) ,*load-pathname*) other))) - ;; Defclass of a class with a forward-referenced superclass does not - ;; have a wrapper. RES is the incomplete PCL class. The Lisp class - ;; does not yet exist. Maybe should return NIL in that case as RES - ;; is not useful to the user? - (and (class-wrapper res) (sb-kernel:layout-class (class-wrapper res))))) + res)) (setf (gdefinition 'load-defclass) #'real-load-defclass) @@ -336,8 +332,10 @@ (defmethod ensure-class-using-class (name (class null) &rest args &key) (multiple-value-bind (meta initargs) (ensure-class-values class args) + (set-class-type-translation (class-prototype meta) name) (setf class (apply #'make-instance meta :name name initargs) (find-class name) class) + (set-class-type-translation class name) class)) (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) @@ -346,6 +344,7 @@ (unless (eq (class-of class) meta) (change-class class meta)) (apply #'reinitialize-instance class initargs) (setf (find-class name) class) + (set-class-type-translation class name) class)) (defmethod class-predicate-name ((class t)) @@ -641,9 +640,9 @@ (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'slots) (compute-slots class)) - (let ((lclass (cl:find-class (class-name class)))) - (setf (sb-kernel:class-pcl-class lclass) class) - (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass))) + (let ((lclass (sb-kernel:find-classoid (class-name class)))) + (setf (sb-kernel:classoid-pcl-class lclass) class) + (setf (slot-value class 'wrapper) (sb-kernel:classoid-layout lclass))) (update-pv-table-cache-info class) (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) |