Declassification of INSTANCE and FUNCALLABLE-INSTANCE.
It turns out that the classes INSTANCE and
FUNCALLABLE-INSTANCE, as expressed in instance-pointer-lowtag
and funcallable-instance-widetag, are incompatible with the
MOP's notion of classes: the types INSTANCE and
FUNCALLABLE-INSTANCE are necessarily disjoint (no instance can
have a widetag of anything other than instance-header-widetag),
but FUNCALLABLE-STANDARD-OBJECT is required to be a subclass of
STANDARD-OBJECT, and must therefore have the superclasses of
STANDARD-OBJECT among its superclasses. If INSTANCE is one of
those, FUNCALLABLE-INSTANCE cannot be, so F-S-Os would not be of
type FUNCALLABLE-INSTANCE (which is wrong); if it is not one of
those, then ordinary S-Os would not be of type INSTANCE (which
is wrong). CMUCL, at the time of writing, exhibits type system
confusion in this area, as demonstrated by CSR cmucl-imp
2005-09-0x).
So, we need to do something else; probably most straightforward
to make INSTANCE and FUNCALLABLE-INSTANCE named types, as they
are of the same order of specialness as e.g. T -- not quite as
special, but almost. Some hacking later...
... the usual type system dance. Play whack-a-mole with test
failures and compilation failures until they all go
away. Primtype, class, typetran, and so on are
fiddled with.
... somewhat hacky code for determining when a class is subtypep
instance / funcallable-instance.
... different hard-coded constants for genesis; don't make a
special instance-layout, because the instance class is
gone.
... just to prove we've achieved something, make STANDARD-OBJECT
a superclass of FUNCALLABLE-STANDARD-OBJECT.
(Supporting METAOBJECT should be straightforward now)
... many many new tests, both of the before-xc variety (it's
amazing in how many ways I can get the type system
wrong) and of the regular form. Also add some
ctor tests that aren't exercised yet.
funcallable-instances. (reported by Cyrus Harmon)
* bug fix: FUNCTIONP and (LAMBDA (X) (TYPEP X 'FUNCTION)) are now
consistent, even on internal alternate-metaclass objects.
+ * bug fix: SB-MOP:FUNCALLABLE-STANDARD-OBJECT is now a subclass of
+ STANDARD-OBJECT, as required by AMOP.
* threads
** bug fix: parent thread now can be gc'ed even with a live
child thread
(defmethod inspected-description ((object standard-object))
(format nil "~W" (class-of object)))
-(defmethod inspected-description ((object sb-kernel:funcallable-instance))
- (format nil "a funcallable-instance of type ~S" (type-of object)))
-
(defmethod inspected-description ((object function))
(format nil "~S" object) nil)
(let ((components (inspected-standard-object-parts object)))
(list components (length components) :named nil)))
-(defmethod inspected-parts ((object sb-kernel:funcallable-instance))
- (let ((components (inspected-standard-object-parts object)))
- (list components (length components) :named nil)))
-
(defmethod inspected-parts ((object condition))
(let ((components (inspected-standard-object-parts object)))
(list components (length components) :named nil)))
;; uncertain, since a subclass of both might be defined
nil)))
+;;; KLUDGE: we need this to deal with the special-case INSTANCE and
+;;; FUNCALLABLE-INSTANCE types (which used to be CLASSOIDs until CSR
+;;; discovered that this was incompatible with the MOP class
+;;; hierarchy). See NAMED :COMPLEX-SUBTYPEP-ARG2
+(defvar *non-instance-classoid-types*
+ '(symbol system-area-pointer weak-pointer code-component
+ lra fdefn random-class))
+
;;; KLUDGE: we need this because of the need to represent
;;; intersections of two classes, even when empty at a given time, as
;;; uncanonicalized intersections because of the possibility of later
(symbol :codes (#.sb!vm:symbol-header-widetag)
:prototype-form '#:mu)
- (instance :state :read-only)
-
(system-area-pointer :codes (#.sb!vm:sap-widetag)
:prototype-form (sb!sys:int-sap 42))
(weak-pointer :codes (#.sb!vm:weak-pointer-widetag)
#.sb!vm:simple-fun-header-widetag)
:state :read-only
:prototype-form (function (lambda () 42)))
- (funcallable-instance
- :inherits (function)
- :state :read-only)
(number :translation number)
(complex
:prototype-form 'nil)
(stream
:state :read-only
- :depth 3
- :inherits (instance))
+ :depth 2)
(file-stream
:state :read-only
- :depth 5
+ :depth 4
:inherits (stream))
(string-stream
:state :read-only
- :depth 5
+ :depth 4
:inherits (stream)))))
;;; See also src/code/class-init.lisp where we finish setting up the
(dolist (x '(;; Why is STREAM duplicated in this list? Because, when
;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
;; a vector containing the elements of the list below,
- ;; i.e. '(T INSTANCE STREAM STREAM), is created, and
+ ;; i.e. '(T STREAM STREAM), is created, and
;; this is what the function ORDER-LAYOUT-INHERITS
;; would do, too.
;;
;; So, the purpose is to guarantee a valid layout for
;; the FUNDAMENTAL-STREAM class, matching what
;; ORDER-LAYOUT-INHERITS would do.
- ;; ORDER-LAYOUT-INHERITS would place STREAM at index 3
- ;; in the INHERITS(-VECTOR). Index 2 would not be
+ ;; ORDER-LAYOUT-INHERITS would place STREAM at index 2
+ ;; in the INHERITS(-VECTOR). Index 1 would not be
;; filled, so STREAM is duplicated there (as
;; ORDER-LAYOUTS-INHERITS would do). Maybe the
;; duplicate definition could be removed (removing a
;; redefined after PCL is set up, anyway. But to play
;; it safely, we define the class with a valid INHERITS
;; vector.
- (fundamental-stream (t instance stream stream))))
+ (fundamental-stream (t stream stream))))
(/show0 "defining temporary STANDARD-CLASS")
(let* ((name (first x))
(inherits-list (second x))
(!defstruct-with-alternate-metaclass condition
:slot-names (actual-initargs assigned-slots)
:boa-constructor %make-condition-object
- :superclass-name instance
+ :superclass-name t
:metaclass-name condition-classoid
:metaclass-constructor make-condition-classoid
:dd-type structure)
;;; CL:STREAM.
(deftype ansi-stream () 'stream)
-;;; In the target SBCL, the INSTANCE type refers to a base
-;;; implementation for compound types. There's no way to express
-;;; exactly that concept portably, but we can get essentially the same
-;;; effect by testing for any of the standard types which would, in
-;;; the target SBCL, be derived from INSTANCE:
(deftype sb!kernel:instance ()
- '(or condition standard-object structure-object))
+ '(or condition structure-object standard-object))
+(deftype sb!kernel:funcallable-instance ()
+ (error "not clear how to represent FUNCALLABLE-INSTANCE type"))
+
+;;; In the target SBCL, the INSTANCE type refers to a base
+;;; implementation for compound types with lowtag
+;;; INSTANCE-POINTER-LOWTAG. There's no way to express exactly that
+;;; concept portably, but we can get essentially the same effect by
+;;; testing for any of the standard types which would, in the target
+;;; SBCL, be derived from INSTANCE:
+(defun %instancep (x)
+ (typep x '(or condition structure-object standard-object)))
;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
;;; host Common Lisp.
'(sb!alien:alien))
(member target-type
'(system-area-pointer
- funcallable-instance
sb!alien-internals:alien-value)))
(values nil t))
(;; special case when TARGET-TYPE isn't a type spec, but
'(array simple-string simple-vector string vector))
(values (typep host-object target-type) t))
(;; general cases of vectors
- (and (not (unknown-type-p (values-specifier-type target-type)))
+ (and (not (hairy-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:vector))
(if (vectorp host-object)
(warn-and-give-up) ; general-case vectors being way too hard
(values nil t))) ; but "obviously not a vector" being easy
(;; general cases of arrays
- (and (not (unknown-type-p (values-specifier-type target-type)))
+ (and (not (hairy-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:array))
(if (arrayp host-object)
(warn-and-give-up) ; general-case arrays being way too hard
(t
(values nil t))))
(;; Complexes suffer the same kind of problems as arrays
- (and (not (unknown-type-p (values-specifier-type target-type)))
+ (and (not (hairy-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:complex))
(if (complexp host-object)
(warn-and-give-up) ; general-case complexes being way too hard
;; default. (But note
;; FUNCALLABLE-STRUCTUREs need
;; assistance here)
- (inherits (vector (find-layout t)
- (find-layout 'instance))))
+ (inherits (vector (find-layout t))))
(multiple-value-bind (classoid layout old-layout)
(multiple-value-bind (clayout clayout-p)
;; and it's not a general-purpose facility, so sanity check our
;; own code.
(structure
- (aver (eq superclass-name 'instance)))
+ (aver (eq superclass-name 't)))
(funcallable-structure
- (aver (eq superclass-name 'funcallable-instance)))
+ (aver (eq superclass-name 'function)))
(t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type)))
(setf (dd-alternate-metaclass dd) (list superclass-name
metaclass-name
;; Note: This has an ALTERNATE-METACLASS only because of blind
;; clueless imitation of the CMU CL code -- dunno if or why it's
;; needed. -- WHN
- (dd-alternate-metaclass dd) '(instance)
+ (dd-alternate-metaclass dd) '(t)
(dd-slots dd) nil
(dd-length dd) 1
(dd-type dd) 'structure)
;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
(defun compound-object-p (x)
(or (consp x)
- (typep x 'instance)
+ (%instancep x)
(typep x '(array t *))))
\f
;;;; the COLLECT macro
(obj (svref *current-fop-table* obi))
(idx (read-word-arg))
(val (pop-stack)))
- (if (typep obj 'instance)
+ (if (%instancep obj)
(setf (%instance-ref obj idx) val)
(setf (svref obj idx) val))))
t
(inspected-standard-object-elements object)))
-(defmethod inspected-parts ((object funcallable-instance))
- (values (format nil "The object is a FUNCALLABLE-INSTANCE of type ~S.~%"
- (type-of object))
- t
- (inspected-standard-object-elements object)))
-
(defmethod inspected-parts ((object condition))
(values (format nil "The object is a CONDITION of type ~S.~%"
(type-of object))
:operands (list this that)))
(deferr object-not-type-error (object type)
- (error (if (and (typep object 'instance)
+ (error (if (and (%instancep object)
(layout-invalid (%instance-layout object)))
'layout-invalid
'type-error)
;; In SBCL it also used to denote universal VALUES type.
(frob * *wild-type*)
(frob nil *empty-type*)
- (frob t *universal-type*))
+ (frob t *universal-type*)
+ ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that
+ ;; view of them was incompatible with requirements on the MOP
+ ;; metaobject class hierarchy: the INSTANCE and
+ ;; FUNCALLABLE-INSTANCE types are disjoint (instances have
+ ;; instance-pointer-lowtag; funcallable-instances have
+ ;; fun-pointer-lowtag), while FUNCALLABLE-STANDARD-OBJECT is
+ ;; required to be a subclass of STANDARD-OBJECT. -- CSR,
+ ;; 2005-09-09
+ (frob instance *instance-type*)
+ (frob funcallable-instance *funcallable-instance-type*))
(setf *universal-fun-type*
(make-fun-type :wild-args t
:returns *wild-type*)))
(!define-type-method (named :simple-subtypep) (type1 type2)
(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
- (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
+ (aver (not (eq type1 type2)))
+ (values (or (eq type1 *empty-type*)
+ (eq type2 *wild-type*)
+ (eq type2 *universal-type*)) t))
(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
;; This AVER causes problems if we write accurate methods for the
;; is a compound type which might contain a hairy type) by
;; returning uncertainty.
(values nil nil))
+ ((eq type1 *funcallable-instance-type*)
+ (values (eq type2 (specifier-type 'function)) t))
(t
- ;; By elimination, TYPE1 is the universal type.
- (aver (eq type1 *universal-type*))
;; This case would have been picked off by the SIMPLE-SUBTYPEP
;; method, and so shouldn't appear here.
- (aver (not (eq type2 *universal-type*)))
- ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the
- ;; universal type in disguise, TYPE2 is not a superset of TYPE1.
+ (aver (not (named-type-p type2)))
+ ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another
+ ;; named type in disguise, TYPE2 is not a superset of TYPE1.
(values nil t))))
(!define-type-method (named :complex-subtypep-arg2) (type1 type2)
(cond ((eq type2 *universal-type*)
(values t t))
((or (type-might-contain-other-types-p type1)
+ ;; some CONS types can conceal danger
(and (cons-type-p type1)
(cons-type-might-be-empty-type type1)))
- ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in
- ;; disguise. So we'd better delegate.
+ ;; those types can be other types in disguise. So we'd
+ ;; better delegate.
(invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (eq type2 *instance-type*) (classoid-p type1))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ (values nil t)
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (functionp (find (classoid-layout (find-classoid 'function))
+ inherits)))
+ (cond
+ (functionp
+ (values nil t))
+ ((eq type1 (find-classoid 'function))
+ (values nil t))
+ ((or (basic-structure-classoid-p type1)
+ #+nil
+ (condition-classoid-p type1))
+ (values t t))
+ (t (values nil nil))))))
+ ((and (eq type2 *funcallable-instance-type*) (classoid-p type1))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ (values nil t)
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (functionp (find (classoid-layout (find-classoid 'function))
+ inherits)))
+ (values (if functionp t nil) t))))
(t
- ;; FIXME: This seems to rely on there only being 2 or 3
+ ;; FIXME: This seems to rely on there only being 4 or 5
;; NAMED-TYPE values, and the exclusion of various
;; possibilities above. It would be good to explain it and/or
;; rewrite it so that it's clearer.
- (values (not (eq type2 *empty-type*)) t))))
+ (values nil t))))
(!define-type-method (named :complex-intersection2) (type1 type2)
;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
;; Perhaps when bug 85 is fixed it can be reenabled.
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
- (hierarchical-intersection2 type1 type2))
+ (cond
+ ((eq type2 *instance-type*)
+ (if (classoid-p type1)
+ (if (and (not (member type1 *non-instance-classoid-types*
+ :key #'find-classoid))
+ (not (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))))
+ type1
+ *empty-type*)
+ (if (type-might-contain-other-types-p type1)
+ nil
+ *empty-type*)))
+ ((eq type2 *funcallable-instance-type*)
+ (if (classoid-p type1)
+ (if (and (not (member type1 *non-instance-classoid-types*
+ :key #'find-classoid))
+ (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1))))
+ type1
+ (if (type= type1 (find-classoid 'function))
+ type1
+ nil))
+ (if (fun-type-p type1)
+ nil
+ (if (type-might-contain-other-types-p type1)
+ nil
+ *empty-type*))))
+ (t (hierarchical-intersection2 type1 type2))))
(!define-type-method (named :complex-union2) (type1 type2)
;; Perhaps when bug 85 is fixed this can be reenabled.
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
- (hierarchical-union2 type1 type2))
+ (cond
+ ((eq type2 *instance-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1))))
+ nil
+ type2)
+ nil))
+ ((eq type2 *funcallable-instance-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (not (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ (if (eq type1 (specifier-type 'function))
+ type1
+ type2))
+ nil))
+ (t (hierarchical-union2 type1 type2))))
(!define-type-method (named :negate) (x)
(aver (not (eq x *wild-type*)))
(cond
((eq x *universal-type*) *empty-type*)
((eq x *empty-type*) *universal-type*)
- (t (bug "NAMED type not universal, wild or empty: ~S" x))))
+ ((or (eq x *instance-type*)
+ (eq x *funcallable-instance-type*))
+ (make-negation-type :type x))
+ (t (bug "NAMED type unexpected: ~S" x))))
(!define-type-method (named :unparse) (x)
(named-type-name x))
(t
(let* ((classoid (layout-classoid (layout-of object)))
(name (classoid-name classoid)))
- (if (typep object 'instance)
+ (if (%instancep object)
(case name
(sb!alien-internals:alien-value
`(sb!alien:alien
((hash-table-p x)
(and (hash-table-p y)
(hash-table-equalp x y)))
- ((typep x 'instance)
+ ((%instancep x)
(let* ((layout-x (%instance-layout x))
(len (layout-length layout-x)))
- (and (typep y 'instance)
+ (and (%instancep y)
(eq layout-x (%instance-layout y))
(structure-classoid-p (layout-classoid layout-x))
(do ((i 1 (1+ i)))
(defvar *empty-type*)
(defvar *universal-type*)
(defvar *universal-fun-type*)
+(defvar *instance-type*)
+(defvar *funcallable-instance-type*)
;;; a vector that maps type codes to layouts, used for quickly finding
;;; the layouts of built-in classes
(when (layout-invalid layout)
(error "An obsolete structure accessor function was called."))
(/noshow0 "back from testing LAYOUT-INVALID LAYOUT")
- ;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that
- ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code.
- (and (typep obj 'instance)
+ (and (%instancep obj)
(let ((obj-layout (%instance-layout obj)))
(cond ((eq obj-layout layout)
;; (In this case OBJ-LAYOUT can't be invalid, because
named-type
member-type
array-type
- character-set-type
+ character-set-type
built-in-classoid
cons-type)
(values (%typep obj type) t))
(classoid
- (if (if (csubtypep type (specifier-type 'funcallable-instance))
+ (if (if (csubtypep type (specifier-type 'function))
(funcallable-instance-p obj)
- (typep obj 'instance))
+ (%instancep obj))
(if (eq (classoid-layout type)
(info :type :compiler-layout (classoid-name type)))
(values (sb!xc:typep obj type) t)
#!-sb-fluid (declaim (inline layout-of))
(defun layout-of (x)
(declare (optimize (speed 3) (safety 0)))
- (cond ((typep x 'instance) (%instance-layout x))
+ (cond ((%instancep x) (%instance-layout x))
((funcallable-instance-p x) (%funcallable-instance-layout x))
((null x)
;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))).
(named-type
(ecase (named-type-name type)
((* t) t)
+ ((instance) (%instancep object))
+ ((funcallable-instance) (funcallable-instance-p object))
((nil) nil)))
(numeric-type
(and (numberp object)
(number-to-core target-layout-length)
(vector-in-core)
;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
- (number-to-core 4)
+ (number-to-core 3)
;; no raw slots in LAYOUT:
(number-to-core 0)))
(write-wordindexed *layout-layout*
(vector-in-core)
(number-to-core 0)
(number-to-core 0)))
- (i-layout
- (make-cold-layout 'instance
- (number-to-core 0)
- (vector-in-core t-layout)
- (number-to-core 1)
- (number-to-core 0)))
(so-layout
(make-cold-layout 'structure-object
(number-to-core 1)
- (vector-in-core t-layout i-layout)
- (number-to-core 2)
+ (vector-in-core t-layout)
+ (number-to-core 1)
(number-to-core 0)))
(bso-layout
(make-cold-layout 'structure!object
(number-to-core 1)
- (vector-in-core t-layout i-layout so-layout)
- (number-to-core 3)
+ (vector-in-core t-layout so-layout)
+ (number-to-core 2)
(number-to-core 0)))
(layout-inherits (vector-in-core t-layout
- i-layout
so-layout
bso-layout)))
;; have an exact primitive type.
(return (part-of function)))
(multiple-value-bind (ptype ptype-exact)
- (primitive-type type)
- (when ptype-exact
- ;; Apart from the previous kludge exact primitive
- ;; types should match, if indeed there are any. It
- ;; may be that this assumption isn't really safe,
- ;; but at least we'll see what breaks. -- NS 20041104
- (aver (or (not exact) (eq ptype res)))
- (setq exact t))
- (when (or ptype-exact (and (not exact) (eq res (any))))
- ;; Try to find a narrower representation then
- ;; (any). Takes care of undecidable types in
- ;; intersections with decidable ones.
- (setq res ptype))))))
+ (primitive-type type)
+ (when ptype-exact
+ ;; Apart from the previous kludge exact primitive
+ ;; types should match, if indeed there are any. It
+ ;; may be that this assumption isn't really safe,
+ ;; but at least we'll see what breaks. -- NS 20041104
+ (aver (or (not exact) (eq ptype res)))
+ (setq exact t))
+ (when (or ptype-exact (and (not exact) (eq res (any))))
+ ;; Try to find a narrower representation then
+ ;; (any). Takes care of undecidable types in
+ ;; intersections with decidable ones.
+ (setq res ptype))))))
(member-type
(let* ((members (member-type-members type))
(res (primitive-type-of (first members))))
(named-type
(ecase (named-type-name type)
((t *) (values *backend-t-primitive-type* t))
+ ((instance) (exactly instance))
+ ((funcallable-instance) (part-of function))
((nil) (any))))
- (character-set-type
- (let ((pairs (character-set-type-pairs type)))
- (if (and (= (length pairs) 1)
- (= (caar pairs) 0)
- (= (cdar pairs) (1- sb!xc:char-code-limit)))
- (exactly character)
- (part-of character))))
- (built-in-classoid
- (case (classoid-name type)
- ((complex function instance
- system-area-pointer weak-pointer)
- (values (primitive-type-or-lose (classoid-name type)) t))
- (funcallable-instance
- (part-of function))
- (cons-type
- (part-of list))
- (t
- (any))))
- (fun-type
- (exactly function))
- (classoid
- (if (csubtypep type (specifier-type 'function))
- (part-of function)
- (part-of instance)))
- (ctype
- (if (csubtypep type (specifier-type 'function))
- (part-of function)
- (any)))))))
+ (character-set-type
+ (let ((pairs (character-set-type-pairs type)))
+ (if (and (= (length pairs) 1)
+ (= (caar pairs) 0)
+ (= (cdar pairs) (1- sb!xc:char-code-limit)))
+ (exactly character)
+ (part-of character))))
+ (built-in-classoid
+ (case (classoid-name type)
+ ((complex function system-area-pointer weak-pointer)
+ (values (primitive-type-or-lose (classoid-name type)) t))
+ (cons-type
+ (part-of list))
+ (t
+ (any))))
+ (fun-type
+ (exactly function))
+ (classoid
+ (if (csubtypep type (specifier-type 'function))
+ (part-of function)
+ (part-of instance)))
+ (ctype
+ (if (csubtypep type (specifier-type 'function))
+ (part-of function)
+ (any)))))))
(/show0 "primtype.lisp end of file")
(source-transform-array-typep object type))
(cons-type
(source-transform-cons-typep object type))
- (character-set-type
- (source-transform-character-set-typep object type))
+ (character-set-type
+ (source-transform-character-set-typep object type))
(t nil))
`(%typep ,object ,spec)))
(values nil t)))
(!defstruct-with-alternate-metaclass ctor
:slot-names (function-name class-name class initargs)
:boa-constructor %make-ctor
- :superclass-name funcallable-instance
+ :superclass-name function
:metaclass-name random-pcl-classoid
:metaclass-constructor make-random-pcl-classoid
:dd-type funcallable-structure
;; I'm not sure why these are removed from
;; the list, but that's what the original
;; CMU CL code did. -- WHN 20000715
- '(t instance
- funcallable-instance
- function stream
+ '(t function stream
file-stream string-stream)))
sb-kernel::*built-in-classes*))))
(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
(defclass t () ()
(:metaclass built-in-class))
-(defclass instance (t) ()
- (:metaclass built-in-class))
-
(defclass function (t) ()
(:metaclass built-in-class))
-(defclass funcallable-instance (function) ()
- (:metaclass built-in-class))
-
-(defclass stream (instance) ()
+(defclass stream (t) ()
(:metaclass built-in-class))
(defclass file-stream (stream) ()
(defclass slot-object (t) ()
(:metaclass slot-class))
-(defclass condition (slot-object instance) ()
+(defclass condition (slot-object) ()
(:metaclass condition-class))
-(defclass structure-object (slot-object instance) ()
+(defclass structure-object (slot-object) ()
(:metaclass structure-class))
(defstruct (dead-beef-structure-object
(defclass std-object (slot-object) ()
(:metaclass std-class))
-(defclass standard-object (std-object instance) ())
+(defclass standard-object (std-object) ())
-(defclass funcallable-standard-object (std-object funcallable-instance)
+(defclass funcallable-standard-object (standard-object function)
()
(:metaclass funcallable-standard-class))
;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30
:slot-names (clos-slots name hash-code)
:boa-constructor %make-pcl-funcallable-instance
- :superclass-name funcallable-instance
+ :superclass-name function
:metaclass-name random-pcl-classoid
:metaclass-constructor make-random-pcl-classoid
:dd-type funcallable-structure
(!defstruct-with-alternate-metaclass standard-instance
:slot-names (slots hash-code)
:boa-constructor %make-standard-instance
- :superclass-name instance
+ :superclass-name t
:metaclass-name standard-classoid
:metaclass-constructor make-standard-classoid
:dd-type structure
(make-instance 'class-with-symbol-initarg slot arg))
(assert (eql (slot-value (make-thing 1) 'slot) 1))
(assert (eql (slot-value (make-other-thing 'slot 2) 'slot) 2))
+\f
+;;; test that ctors can be used with the literal class
+(eval-when (:compile-toplevel)
+ (defclass ctor-literal-class () ())
+ (defclass ctor-literal-class2 () ()))
+(defun ctor-literal-class ()
+ (make-instance #.(find-class 'ctor-literal-class)))
+(defun ctor-literal-class2 ()
+ (make-instance '#.(find-class 'ctor-literal-class2)))
+(with-test (:name (:ctor :literal-class-unquoted))
+ (assert (typep (ctor-literal-class) 'ctor-literal-class)))
+(with-test (:name (:ctor :literal-class-quoted))
+ (assert (typep (ctor-literal-class2) 'ctor-literal-class2)))
(load "assertoid.lisp")
(defpackage "CLOS-IMPURE"
- (:use "CL" "ASSERTOID"))
+ (:use "CL" "ASSERTOID" "TEST-UTIL"))
(in-package "CLOS-IMPURE")
\f
;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
(assert (equal (list (slot-value c1 'class-slot)
(slot-value c2 'class-slot))
(list 1 1))))))
-
+\f
+;;; tests of ctors on anonymous classes
+(defparameter *unnamed* (defclass ctor-unnamed-literal-class () ()))
+(setf (class-name *unnamed*) nil)
+(setf (find-class 'ctor-unnamed-literal-class) nil)
+(defparameter *unnamed2* (defclass ctor-unnamed-literal-class2 () ()))
+(defun ctor-unnamed-literal-class ()
+ (make-instance '#.*unnamed*))
+(compile 'ctor-unnamed-literal-class)
+(defun ctor-unnamed-literal-class2 ()
+ (make-instance '#.(find-class 'ctor-unnamed-literal-class2)))
+(compile 'ctor-unnamed-literal-class2)
+(defun ctor-unnamed-literal-class2/symbol ()
+ (make-instance 'ctor-unnamed-literal-class2))
+(compile 'ctor-unnamed-literal-class2/symbol)
+(setf (class-name *unnamed2*) nil)
+(setf (find-class 'ctor-unnamed-literal-class2) nil)
+(with-test (:name (:ctor :unnamed-before))
+ (assert (typep (ctor-unnamed-literal-class) *unnamed*)))
+(with-test (:name (:ctor :unnamed-after))
+ (assert (typep (ctor-unnamed-literal-class2) *unnamed2*)))
+(with-test (:name (:ctor :unnamed-after/symbol))
+ (assert (raises-error? (ctor-unnamed-literal-class2/symbol))))
+\f
;;;; success
--- /dev/null
+;;;; miscellaneous non-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.
+
+(assert (subtypep 'sb-mop:funcallable-standard-object 'standard-object))
+
+(assert (find (find-class 'sb-mop:funcallable-standard-object)
+ (sb-mop:class-direct-subclasses (find-class 'standard-object))))
+
+(assert (find (find-class 'standard-object)
+ (sb-mop:class-direct-superclasses
+ (find-class 'sb-mop:funcallable-standard-object))))
(specifier-type '(member #\b #\c #\f)))
(specifier-type '(member #\c))))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'package 'instance)
+ (assert yes)
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'symbol 'instance)
+ (assert (not yes))
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'package 'funcallable-instance)
+ (assert (not yes))
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'symbol 'funcallable-instance)
+ (assert (not yes))
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'funcallable-instance 'function)
+ (assert yes)
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'array 'instance)
+ (assert (not yes))
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'character 'instance)
+ (assert (not yes))
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'number 'instance)
+ (assert (not yes))
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'package '(and (or symbol package) instance))
+ (assert yes)
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep '(and (or double-float integer) instance) 'nil)
+ (assert yes)
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep '(and (or double-float integer) funcallable-instance) 'nil)
+ (assert yes)
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'instance 'type-specifier)
+ (assert yes)
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep 'type-specifier 'instance)
+ (assert (not yes))
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep '(and (function (t)) funcallable-instance) 'nil)
+ (assert (not yes)))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep '(and fixnum function) 'nil)
+ (assert yes)
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep '(and fixnum hash-table) 'nil)
+ (assert yes)
+ (assert win))
+(multiple-value-bind (yes win)
+ (sb-xc:subtypep '(function) '(function (t &rest t)))
+ (assert (not yes))
+ (assert win))
+
(/show "done with tests/type.before-xc.lisp")
(mapcar #'find-class '(simple-condition
condition
sb-pcl::slot-object
- sb-kernel:instance
t))))
;; stream classes
sb-pcl::std-object
sb-pcl::slot-object
stream
- sb-kernel:instance
t))))
(assert (equal (sb-pcl:class-precedence-list (find-class
'fundamental-stream))
standard-object
sb-pcl::std-object
sb-pcl::slot-object stream
- sb-kernel:instance t))))
+ t))))
(assert (subtypep (find-class 'stream) (find-class t)))
(assert (subtypep (find-class 'fundamental-stream) 'stream))
(assert (not (subtypep 'stream 'fundamental-stream)))))
'(cons (satisfies bar) t))
(assert (null cyes))
(assert (null cwin))))
+
+(multiple-value-bind (yes win)
+ (subtypep 'generic-function 'function)
+ (assert yes)
+ (assert win))
+;; this would be in some internal test suite like type.before-xc.lisp
+;; except that generic functions don't exist at that stage.
+(multiple-value-bind (yes win)
+ (subtypep 'generic-function 'sb-kernel:funcallable-instance)
+ (assert yes)
+ (assert win))
;;; 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.4.53"
+"0.9.4.54"
projects / sbcl.git / commitdiff