(remhash name *forward-referenced-layouts*)
(%note-type-defined name)
- (setf (info :type :kind name) :instance)
+ ;; we need to handle things like
+ ;; (setf (find-class 'foo) (find-class 'integer))
+ ;; and
+ ;; (setf (find-class 'integer) (find-class 'integer))
+ (cond
+ ((built-in-classoid-p new-value)
+ (setf (info :type :kind name) (or (info :type :kind name) :defined))
+ (let ((translation (built-in-classoid-translation new-value)))
+ (when translation
+ (setf (info :type :translator name)
+ (lambda (c) (declare (ignore c)) translation)))))
+ (t (setf (info :type :kind name) :instance)))
(setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
(unless (eq (info :type :compiler-layout name)
(classoid-layout new-value))
(!define-type-class classoid)
+;;; We might be passed classoids with invalid layouts; in any pairwise
+;;; class comparison, we must ensure that both are valid before
+;;; proceeding.
+(defun ensure-classoid-valid (classoid layout)
+ (aver (eq classoid (layout-classoid layout)))
+ (when (layout-invalid layout)
+ (if (typep classoid 'standard-classoid)
+ (let ((class (classoid-pcl-class classoid)))
+ (cond
+ ((sb!pcl:class-finalized-p class)
+ (sb!pcl::force-cache-flushes class))
+ ((sb!pcl::class-has-a-forward-referenced-superclass-p class)
+ (error "Invalid, unfinalizeable class ~S (classoid ~S)."
+ class classoid))
+ (t (sb!pcl:finalize-inheritance class))))
+ (error "Don't know how to ensure validity of ~S (not ~
+ a STANDARD-CLASSOID)." classoid))))
+
+(defun ensure-both-classoids-valid (class1 class2)
+ (do ((layout1 (classoid-layout class1) (classoid-layout class1))
+ (layout2 (classoid-layout class2) (classoid-layout class2))
+ (i 0 (+ i 1)))
+ ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))))
+ (aver (< i 2))
+ (ensure-classoid-valid class1 layout1)
+ (ensure-classoid-valid class2 layout2)))
+
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
;;; operations.
(!define-type-method (classoid :simple-subtypep) (class1 class2)
(aver (not (eq class1 class2)))
+ (ensure-both-classoids-valid class1 class2)
(let ((subclasses (classoid-subclasses class2)))
(if (and subclasses (gethash class1 subclasses))
(values t t)
(!define-type-method (classoid :simple-intersection2) (class1 class2)
(declare (type classoid class1 class2))
+ (ensure-both-classoids-valid class1 class2)
(cond ((eq class1 class2)
class1)
;; If one is a subclass of the other, then that is the
;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
(defun classoid-typep (obj-layout classoid object)
(declare (optimize speed))
- (when (layout-invalid obj-layout)
- (if (and (typep (classoid-of object) 'standard-classoid) object)
- (setq obj-layout (sb!pcl::check-wrapper-validity object))
- (error "TYPEP was called on an obsolete object (was class ~S)."
- (classoid-proper-name (layout-classoid obj-layout)))))
- (let ((layout (classoid-layout classoid))
- (obj-inherits (layout-inherits obj-layout)))
- (when (layout-invalid layout)
- (error "The class ~S is currently invalid." classoid))
- (or (eq obj-layout layout)
- (dotimes (i (length obj-inherits) nil)
- (when (eq (svref obj-inherits i) layout)
- (return t))))))
-
-;;; This implementation is a placeholder to use until PCL is set up,
-;;; at which time it will be overwritten by a real implementation.
-(defun sb!pcl::check-wrapper-validity (object)
- object)
+ (multiple-value-bind (obj-layout layout)
+ (do ((layout (classoid-layout classoid) (classoid-layout classoid))
+ (i 0 (+ i 1))
+ (obj-layout obj-layout))
+ ((and (not (layout-invalid obj-layout))
+ (not (layout-invalid layout)))
+ (values obj-layout layout))
+ (aver (< i 2))
+ (when (layout-invalid obj-layout)
+ (if (typep (classoid-of object) 'standard-classoid)
+ (setq obj-layout (sb!pcl::check-wrapper-validity object))
+ (error "~S was called on an obsolete object (classoid ~S)."
+ 'typep
+ (classoid-proper-name (layout-classoid obj-layout)))))
+ (ensure-classoid-valid classoid layout))
+ (let ((obj-inherits (layout-inherits obj-layout)))
+ (or (eq obj-layout layout)
+ (dotimes (i (length obj-inherits) nil)
+ (when (eq (svref obj-inherits i) layout)
+ (return t)))))))
(error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
class nor a symbol that names a class."
,gf-class)))
+ (unless (class-finalized-p ,gf-class)
+ (if (class-has-a-forward-referenced-superclass-p ,gf-class)
+ ;; FIXME: reference MOP documentation -- this is an
+ ;; additional requirement on our users
+ (error "The generic function class ~S is not finalizeable" ,gf-class)
+ (finalize-inheritance ,gf-class)))
(remf ,all-keys :generic-function-class)
(remf ,all-keys :environment)
(let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
;;; 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 (layout-classoid layout)))
- (unless (eq (classoid-layout lclass) layout)
+ (let ((classoid (layout-classoid layout))
+ (olayout (class-wrapper class)))
+ (unless (eq (classoid-layout classoid) layout)
(setf (layout-inherits layout)
- (order-layout-inherits
- (map 'simple-vector #'class-wrapper
- (reverse (rest (class-precedence-list class))))))
+ (order-layout-inherits
+ (map 'simple-vector #'class-wrapper
+ (reverse (rest (class-precedence-list class))))))
(register-layout layout :invalidate t)
- ;; Subclasses of formerly forward-referenced-class may be
- ;; unknown to CL:FIND-CLASS and also anonymous. This
- ;; functionality moved here from (SETF FIND-CLASS).
+ ;; FIXME: I don't think this should be necessary, but without it
+ ;; we are unable to compile (TYPEP foo '<class-name>) in the
+ ;; same file as the class is defined. If we had environments,
+ ;; then I think the classsoid whould only be associated with the
+ ;; name in that environment... Alternatively, fix the compiler
+ ;; so that TYPEP foo '<class-name> is slow but compileable.
(let ((name (class-name class)))
- (setf (find-classoid name) lclass
- (classoid-name lclass) name)))))
-
-(defun set-class-type-translation (class name)
- (let ((classoid (find-classoid name nil)))
- (etypecase classoid
- (null)
- (built-in-classoid
- (let ((translation (built-in-classoid-translation classoid)))
- (cond
- (translation
- (aver (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))))))
- (classoid
- (setf (info :type :translator class)
- (lambda (spec) (declare (ignore spec)) classoid))))))
+ (when (and name (symbolp name) (eq name (classoid-name classoid)))
+ (setf (find-classoid name) classoid))))))
+
+(defun set-class-type-translation (class classoid)
+ (when (not (typep classoid 'classoid))
+ (setq classoid (find-classoid classoid nil)))
+ (etypecase classoid
+ (null)
+ (built-in-classoid
+ (let ((translation (built-in-classoid-translation classoid)))
+ (cond
+ (translation
+ (aver (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))))))
+ (classoid
+ (setf (info :type :translator class)
+ (lambda (spec) (declare (ignore spec)) classoid)))))
(clrhash *find-class*)
(!bootstrap-meta-braid)
(aver (eq (classoid-pcl-class found) class))
found))
(t
- (make-standard-classoid :pcl-class class))))
+ (let ((name (slot-value class 'name)))
+ (make-standard-classoid :pcl-class class
+ :name (and (symbolp name) name))))))
(t
(make-random-pcl-classoid :pcl-class class))))))
(t
(defun cpl-or-nil (class)
(if (eq *boot-state* 'complete)
- ;; KLUDGE: why not use (slot-boundp class
- ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is
- ;; used within COMPUTE-APPLICABLE-METHODS, including for
- ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for
- ;; breaking such nasty cycles in effective method computation
- ;; only works for readers and writers, not boundps. It might
- ;; not be too hard to make it work for BOUNDP accessors, but in
- ;; the meantime we use an extra slot for exactly the result of
- ;; the SLOT-BOUNDP that we want. (We cannot use
- ;; CLASS-FINALIZED-P, because in the process of class
- ;; finalization we need to use the CPL which has been computed
- ;; to cache effective methods for slot accessors.) -- CSR,
- ;; 2004-09-19.
- (when (cpl-available-p class)
- (class-precedence-list class))
+ (progn
+ ;; KLUDGE: why not use (slot-boundp class
+ ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is
+ ;; used within COMPUTE-APPLICABLE-METHODS, including for
+ ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for
+ ;; breaking such nasty cycles in effective method computation
+ ;; only works for readers and writers, not boundps. It might
+ ;; not be too hard to make it work for BOUNDP accessors, but in
+ ;; the meantime we use an extra slot for exactly the result of
+ ;; the SLOT-BOUNDP that we want. (We cannot use
+ ;; CLASS-FINALIZED-P, because in the process of class
+ ;; finalization we need to use the CPL which has been computed
+ ;; to cache effective methods for slot accessors.) -- CSR,
+ ;; 2004-09-19.
+
+ (when (cpl-available-p class)
+ (return-from cpl-or-nil (class-precedence-list class)))
+
+ ;; if we can finalize an unfinalized class, then do so
+ (when (and (not (class-finalized-p class))
+ (not (class-has-a-forward-referenced-superclass-p class)))
+ (finalize-inheritance class)
+ (class-precedence-list class)))
+
(early-class-precedence-list class)))
(defun saut-and (specl type)
(defmethod allocate-instance
((class funcallable-standard-class) &rest initargs)
(declare (ignore initargs))
- (unless (class-finalized-p class) (finalize-inheritance class))
+ (unless (class-finalized-p class)
+ (finalize-inheritance class))
(allocate-funcallable-instance (class-wrapper class)))
(defmethod make-reader-method-function ((class funcallable-standard-class)
(with-single-package-locked-error
(:symbol name "using ~A as the class-name argument in ~
(SETF FIND-CLASS)"))
- (let ((cell (find-class-cell name)))
+ (let* ((cell (find-class-cell name))
+ (class (find-class-cell-class cell)))
(setf (find-class-cell-class cell) new-value)
- (when (and (eq *boot-state* 'complete) (null new-value))
- (setf (find-classoid name) nil))
+ (when (eq *boot-state* 'complete)
+ (if (null new-value)
+ (progn
+ (setf (find-classoid name) new-value)
+ (when class
+ ;; KLUDGE: This horror comes about essentially
+ ;; because we use the proper name of a classoid
+ ;; to do TYPEP, which needs to be available
+ ;; early, and also to determine whether TYPE-OF
+ ;; should return the name or the class (using
+ ;; CLASSOID-PROPER-NAME). So if we are removing
+ ;; proper nameness, arrange for
+ ;; CLASSOID-PROPER-NAME to do the right thing
+ ;; too. (This is almost certainly not the right
+ ;; solution; instead, CLASSOID-NAME and
+ ;; FIND-CLASSOID should be direct parallels to
+ ;; CLASS-NAME and FIND-CLASS, and TYPEP on
+ ;; not-yet-final classes should be compileable.
+ (let ((classoid (layout-classoid (slot-value class 'wrapper))))
+ (setf (classoid-name classoid) nil))))
+
+ (let ((classoid (layout-classoid (slot-value new-value 'wrapper))))
+ (setf (find-classoid name) classoid)
+ (set-class-type-translation new-value classoid))))
(when (or (eq *boot-state* 'complete)
(eq *boot-state* 'braid))
(update-ctors 'setf-find-class :class new-value :name name))
(t
(error "~S is not a legal class name." name))))
-(/show "pcl/macros.lisp 230")
-
-(defun find-wrapper (symbol)
- (class-wrapper (find-class symbol)))
-
(/show "pcl/macros.lisp 241")
(defmacro function-funcall (form &rest args)
(set-structure-svuc-method type method)))))))
(defun mec-all-classes-internal (spec precompute-p)
- (unless (invalid-wrapper-p (class-wrapper (specializer-class spec)))
- (cons (specializer-class spec)
- (and (classp spec)
- precompute-p
- (not (or (eq spec *the-class-t*)
- (eq spec *the-class-slot-object*)
- (eq spec *the-class-standard-object*)
- (eq spec *the-class-structure-object*)))
- (let ((sc (class-direct-subclasses spec)))
- (when sc
- (mapcan (lambda (class)
- (mec-all-classes-internal class precompute-p))
- sc)))))))
+ (let ((wrapper (class-wrapper (specializer-class spec))))
+ (unless (or (not wrapper) (invalid-wrapper-p wrapper))
+ (cons (specializer-class spec)
+ (and (classp spec)
+ precompute-p
+ (not (or (eq spec *the-class-t*)
+ (eq spec *the-class-slot-object*)
+ (eq spec *the-class-standard-object*)
+ (eq spec *the-class-structure-object*)))
+ (let ((sc (class-direct-subclasses spec)))
+ (when sc
+ (mapcan (lambda (class)
+ (mec-all-classes-internal class precompute-p))
+ sc))))))))
(defun mec-all-classes (spec precompute-p)
(let ((classes (mec-all-classes-internal spec precompute-p)))
(default '(default)))
(flet ((add-class-list (classes)
(when (or (null new-class) (memq new-class classes))
- (let ((wrappers (get-wrappers-from-classes
- nkeys wrappers classes metatypes)))
- (when (and wrappers
- (eq default (probe-cache cache wrappers default)))
+ (let ((%wrappers (get-wrappers-from-classes
+ nkeys wrappers classes metatypes)))
+ (when (and %wrappers
+ (eq default (probe-cache cache %wrappers default)))
(let ((value (cond ((eq valuep t)
(sdfun-for-caching generic-function
classes))
((eq valuep :constant-value)
(value-for-caching generic-function
classes)))))
- (setq cache (fill-cache cache wrappers value))))))))
+ ;; need to get them again, as finalization might
+ ;; have happened in between, which would
+ ;; invalidate wrappers.
+ (let ((wrappers (get-wrappers-from-classes
+ nkeys wrappers classes metatypes)))
+ (setq cache (fill-cache cache wrappers value)))))))))
(if classes-list
(mapc #'add-class-list classes-list)
(dolist (method (generic-function-methods generic-function))
\f
(defmethod (setf class-name) (new-value class)
(let ((classoid (%wrapper-classoid (class-wrapper class))))
- (setf (classoid-name classoid) new-value))
+ (if (and new-value (symbolp new-value))
+ (setf (classoid-name classoid) new-value)
+ (setf (classoid-name classoid) nil)))
(reinitialize-instance class :name new-value)
new-value)
(defmethod ensure-class-using-class ((class null) name &rest args &key)
(multiple-value-bind (meta initargs)
(ensure-class-values class args)
+ #+nil
(set-class-type-translation (class-prototype meta) name)
(setf class (apply #'make-instance meta :name name initargs))
(without-package-locks
(error "~S is not a class or a legal class name." s))
(t
(or (find-class s nil)
- (make-instance 'forward-referenced-class
- :name s)))))
+ (ensure-class s :metaclass 'forward-referenced-class)))))
(defun ensure-class-values (class initargs)
(let (metaclass metaclassp reversed-plist)
(without-package-locks
(unless (class-finalized-p class)
(let ((name (class-name class)))
- (setf (find-class name) class)
;; KLUDGE: This is fairly horrible. We need to make a
;; full-fledged CLASSOID here, not just tell the compiler that
;; 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.
- (when (and (eq *boot-state* 'complete)
- (null (find-classoid name nil)))
- (setf (find-classoid name)
- (make-standard-classoid :name name)))
- (set-class-type-translation class name)
- (let ((layout (make-wrapper 0 class))
- (classoid (find-classoid name)))
+ (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)
(setf (slot-value class 'wrapper) layout)
(map 'simple-vector #'class-wrapper
(reverse (rest cpl))))))
(register-layout layout :invalidate t)
- (setf (classoid-layout classoid) layout)
- (mapc #'make-preliminary-layout (class-direct-subclasses class))))))))
+ (setf (classoid-layout classoid) layout))))
+ (mapc #'make-preliminary-layout (class-direct-subclasses class)))))
(defmethod shared-initialize :before ((class class) slot-names &key name)
;;; This is called by :after shared-initialize whenever a class is initialized
;;; or reinitialized. The class may or may not be finalized.
(defun update-class (class finalizep)
- ;; Comment from Gerd Moellmann:
- ;;
- ;; Note that we can't simply delay the finalization when CLASS has
- ;; no forward referenced superclasses because that causes bootstrap
- ;; problems.
(without-package-locks
- (when (and (not finalizep)
- (not (class-finalized-p class))
- (not (class-has-a-forward-referenced-superclass-p class)))
- (finalize-inheritance class)
- (dolist (sub (class-direct-subclasses class))
- (update-class sub nil))
- (return-from update-class))
- (when (or finalizep (class-finalized-p class)
- (not (class-has-a-forward-referenced-superclass-p class)))
- (setf (find-class (class-name class)) class)
+ (when (or finalizep (class-finalized-p class))
(update-cpl class (compute-class-precedence-list class))
;; This invocation of UPDATE-SLOTS, in practice, finalizes the
- ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE
- ;; is called at finalization, so that MOP programmers can hook
- ;; into the system as described in "Class Finalization Protocol"
- ;; (section 5.5.2 of AMOP).
+ ;; class.
(update-slots class (compute-slots class))
(update-gfs-of-class class)
(update-initargs class (compute-default-initargs class))
(update-ctors 'finalize-inheritance :class class))
- (unless finalizep
- (dolist (sub (class-direct-subclasses class))
- (update-class sub nil)))))
+ (dolist (sub (class-direct-subclasses class))
+ (update-class sub nil))))
(define-condition cpl-protocol-violation (reference-condition error)
((class :initarg :class :reader cpl-protocol-violation-class)
(let* ((owrapper (class-wrapper class))
(nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
class)))
- (setf (wrapper-instance-slots-layout nwrapper)
- (wrapper-instance-slots-layout owrapper))
- (setf (wrapper-class-slots nwrapper)
- (wrapper-class-slots owrapper))
- (with-pcl-lock
+ (unless (class-finalized-p class)
+ (if (class-has-a-forward-referenced-superclass-p class)
+ (return-from make-instances-obsolete class)
+ (update-cpl class (compute-class-precedence-list class))))
+ (setf (wrapper-instance-slots-layout nwrapper)
+ (wrapper-instance-slots-layout owrapper))
+ (setf (wrapper-class-slots nwrapper)
+ (wrapper-class-slots owrapper))
+ (with-pcl-lock
(update-lisp-class-layout class nwrapper)
- (setf (slot-value class 'wrapper) nwrapper)
- (invalidate-wrapper owrapper :obsolete nwrapper)
- class)))
+ (setf (slot-value class 'wrapper) nwrapper)
+ (invalidate-wrapper owrapper :obsolete nwrapper)
+ class)))
(defmethod make-instances-obsolete ((class symbol))
(make-instances-obsolete (find-class class))
(defmethod change-class ((instance standard-object) (new-class standard-class)
&rest initargs)
+ (unless (class-finalized-p new-class)
+ (finalize-inheritance new-class))
(let ((cpl (class-precedence-list new-class)))
(dolist (class cpl)
(macrolet
(load "package-ctor-bug.lisp")
(assert (= (package-ctor-bug:test) 3))
-(deftype defined-type () 'integer)
-(assert (raises-error?
- (defmethod method-on-defined-type ((x defined-type)) x)))
-(deftype defined-type-and-class () 'integer)
-(setf (find-class 'defined-type-and-class) (find-class 'integer))
-(defmethod method-on-defined-type-and-class ((x defined-type-and-class))
- (1+ x))
-(assert (= (method-on-defined-type-and-class 3) 4))
+(with-test (:name (:defmethod (setf find-class) integer))
+ (mapcar #'eval
+ '(
+ (deftype defined-type () 'integer)
+ (assert (raises-error?
+ (defmethod method-on-defined-type ((x defined-type)) x)))
+ (deftype defined-type-and-class () 'integer)
+ (setf (find-class 'defined-type-and-class) (find-class 'integer))
+ (defmethod method-on-defined-type-and-class
+ ((x defined-type-and-class))
+ (1+ x))
+ (assert (= (method-on-defined-type-and-class 3) 4)))))
;; bug 281
(let ((sb-pcl::*max-emf-precomputation-methods* 0))
(assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test))))
\f
;;; CHANGE-CLASS and tricky allocation.
-(defclass foo ()
+(defclass foo-to-be-changed ()
((a :allocation :class :initform 1)))
-(defclass bar (foo) ())
-(defvar *bar* (make-instance 'bar))
-(defclass baz ()
+(defclass bar-to-be-changed (foo-to-be-changed) ())
+(defvar *bar-to-be-changed* (make-instance 'bar-to-be-changed))
+(defclass baz-to-be-changed ()
((a :allocation :instance :initform 2)))
-(change-class *bar* 'baz)
-(assert (= (slot-value *bar* 'a) 1))
+(change-class *bar-to-be-changed* 'baz-to-be-changed)
+(assert (= (slot-value *bar-to-be-changed* 'a) 1))
+\f
+;;; proper name and class redefinition
+(defvar *to-be-renamed1* (defclass to-be-renamed1 () ()))
+(defvar *to-be-renamed2* (defclass to-be-renamed2 () ()))
+(setf (find-class 'to-be-renamed1) (find-class 'to-be-renamed2))
+(defvar *renamed1* (defclass to-be-renamed1 () ()))
+(assert (not (eq *to-be-renamed1* *to-be-renamed2*)))
+(assert (not (eq *to-be-renamed1* *renamed1*)))
+(assert (not (eq *to-be-renamed2* *renamed1*)))
+\f
+;;; CLASS-NAME (and various other standardized generic functions) have
+;;; their effective methods precomputed; in the process of rearranging
+;;; (SETF FIND-CLASS) and FINALIZE-INHERITANCE, this broke.
+(defclass class-with-odd-class-name-method ()
+ ((a :accessor class-name)))
\f
;;;; success
--- /dev/null
+;;;; 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.
+
+;;; this file tests the programmatic class example from pp.67-69 of
+;;; AMOP.
+
+(defpackage "MOP-17"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-17")
+
+(defun make-programmatic-instance (superclass-names &rest initargs)
+ (apply #'make-instance
+ (find-programmatic-class
+ (mapcar #'find-class superclass-names))
+ initargs))
+
+(defun find-programmatic-class (superclasses)
+ (let ((class (find-if
+ (lambda (class)
+ (equal superclasses
+ (class-direct-superclasses class)))
+ (class-direct-subclasses (car superclasses)))))
+ (or class
+ (make-programmatic-class superclasses))))
+
+(defun make-programmatic-class (superclasses)
+ (make-instance 'standard-class
+ :name (mapcar #'class-name superclasses)
+ :direct-superclasses superclasses
+ :direct-slots '()))
+
+(defclass shape () ())
+(defclass circle (shape) ())
+(defclass color () ())
+(defclass orange (color) ())
+(defclass magenta (color) ())
+(defclass label-type () ())
+(defclass top-labeled (label-type) ())
+(defclass bottom-labeled (label-type) ())
+
+(assert (null (class-direct-subclasses (find-class 'circle))))
+
+(defvar *i1* (make-programmatic-instance '(circle orange top-labeled)))
+(defvar *i2* (make-programmatic-instance '(circle magenta bottom-labeled)))
+(defvar *i3* (make-programmatic-instance '(circle orange top-labeled)))
+
+(assert (not (eq *i1* *i3*)))
+
+(assert (= (length (class-direct-subclasses (find-class 'circle))) 2))
()
(:metaclass funcallable-standard-class))
(make-instance 'bad-funcallable-standard-class))))
-
+\f
+;;; we should be able to make classes with silly names
+(make-instance 'standard-class :name 3)
+(defclass foo () ())
+(reinitialize-instance (find-class 'foo) :name '(a b))
+\f
;;;; success
(assert-t-t (subtypep `(and (member ,misc-629c)
sb-kernel:instance)
nil)))
-
+\f
+;;; this was broken during the FINALIZE-INHERITANCE rearrangement; the
+;;; MAKE-INSTANCE finalizes the superclass, thus invalidating the
+;;; subclass, so SUBTYPEP must be prepared to deal with
+(defclass ansi-tests-defclass1 () ())
+(defclass ansi-tests-defclass3 (ansi-tests-defclass1) ())
+(make-instance 'ansi-tests-defclass1)
+(assert-t-t (subtypep 'ansi-tests-defclass3 'standard-object))
+\f
+;;; so was this
+(let ((class (eval '(defclass to-be-type-ofed () ()))))
+ (setf (find-class 'to-be-type-ofed) nil)
+ (assert (eq (type-of (make-instance class)) class)))
+\f
;;; success
projects / sbcl.git / commitdiff