From 0aecc2b20142e08068c3434273500131cb13fe2d Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 9 Sep 2005 14:16:17 +0000 Subject: [PATCH] 0.9.4.54: 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. --- NEWS | 2 + contrib/sb-aclrepl/inspect.lisp | 7 --- src/code/class.lisp | 28 +++++---- src/code/condition.lisp | 2 +- src/code/cross-misc.lisp | 18 ++++-- src/code/cross-type.lisp | 7 +-- src/code/defstruct.lisp | 9 ++- src/code/early-extensions.lisp | 2 +- src/code/fop.lisp | 2 +- src/code/inspect.lisp | 6 -- src/code/interr.lisp | 2 +- src/code/late-type.lisp | 118 +++++++++++++++++++++++++++++++----- src/code/pred.lisp | 6 +- src/code/primordial-type.lisp | 2 + src/code/target-defstruct.lisp | 4 +- src/code/target-type.lisp | 8 +-- src/code/typep.lisp | 2 + src/compiler/generic/genesis.lisp | 17 ++---- src/compiler/generic/primtype.lisp | 81 ++++++++++++------------- src/compiler/typetran.lisp | 4 +- src/pcl/ctor.lisp | 2 +- src/pcl/defs.lisp | 20 ++---- src/pcl/low.lisp | 4 +- tests/clos.impure-cload.lisp | 13 ++++ tests/clos.impure.lisp | 27 ++++++++- tests/mop.pure.lisp | 25 ++++++++ tests/type.before-xc.lisp | 68 +++++++++++++++++++++ tests/type.impure.lisp | 4 +- tests/type.pure.lisp | 11 ++++ version.lisp-expr | 2 +- 30 files changed, 356 insertions(+), 147 deletions(-) create mode 100644 tests/mop.pure.lisp diff --git a/NEWS b/NEWS index cde12de..fe01370 100644 --- a/NEWS +++ b/NEWS @@ -28,6 +28,8 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: 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 diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 6c3e196..f6cbcc7 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -567,9 +567,6 @@ position with the label if the label is a string." (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) @@ -807,10 +804,6 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (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))) diff --git a/src/code/class.lisp b/src/code/class.lisp index dfee729..4cd2a92 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -875,6 +875,14 @@ NIL is returned when no such class exists." ;; 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 @@ -957,8 +965,6 @@ NIL is returned when no such class exists." (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) @@ -974,9 +980,6 @@ NIL is returned when no such class exists." #.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 @@ -1288,15 +1291,14 @@ NIL is returned when no such class exists." :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 @@ -1363,15 +1365,15 @@ NIL is returned when no such class exists." (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 @@ -1379,7 +1381,7 @@ NIL is returned when no such class exists." ;; 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)) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 782dcdc..a9f9fe8 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -69,7 +69,7 @@ (!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) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index e57a563..a2545b0 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -37,13 +37,19 @@ ;;; 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. diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index c68b2ce..79b8cd1 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -143,7 +143,6 @@ '(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 @@ -164,13 +163,13 @@ '(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 @@ -208,7 +207,7 @@ (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 diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 5b6004d..5ba663c 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -941,8 +941,7 @@ ;; 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) @@ -1531,9 +1530,9 @@ ;; 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 @@ -1657,7 +1656,7 @@ ;; 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) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index c590c21..df396b3 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -173,7 +173,7 @@ ;;; 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 *)))) ;;;; the COLLECT macro diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 712e082..c021a01 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -564,7 +564,7 @@ (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)))) diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index f059e88..6d3b0a5 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -198,12 +198,6 @@ evaluated expressions. 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)) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 0069e54..5bb783f 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -238,7 +238,7 @@ :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) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 92251da..bc99643 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1048,7 +1048,17 @@ ;; 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*))) @@ -1096,7 +1106,10 @@ (!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 @@ -1122,14 +1135,14 @@ ;; 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) @@ -1137,35 +1150,112 @@ (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)) diff --git a/src/code/pred.lisp b/src/code/pred.lisp index d7f5bfa..dc78044 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -139,7 +139,7 @@ (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 @@ -229,10 +229,10 @@ ((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))) diff --git a/src/code/primordial-type.lisp b/src/code/primordial-type.lisp index b6420d7..96dcfbe 100644 --- a/src/code/primordial-type.lisp +++ b/src/code/primordial-type.lisp @@ -17,6 +17,8 @@ (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 diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 2ccc818..31501ff 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -550,9 +550,7 @@ (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 diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index aa7b7a1..321d0a4 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -33,14 +33,14 @@ 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) @@ -119,7 +119,7 @@ #!-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))). diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 0844ebf..49b3964 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -37,6 +37,8 @@ (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) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 9dec385..bb05ce1 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -980,7 +980,7 @@ core and return a descriptor to it." (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* @@ -998,26 +998,19 @@ core and return a descriptor to it." (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))) diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 1492378..4a4489a 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -321,19 +321,19 @@ ;; 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)))) @@ -348,34 +348,33 @@ (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") diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index e88f366..71061b0 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -529,8 +529,8 @@ (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))) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 39c1129..9ae7add 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -109,7 +109,7 @@ (!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 diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index ce413de..251e67a 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -304,9 +304,7 @@ ;; 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*") @@ -316,16 +314,10 @@ (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) () @@ -337,10 +329,10 @@ (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 @@ -350,9 +342,9 @@ (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)) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index e06ca34..ed2d9b8 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -82,7 +82,7 @@ ;; 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 @@ -222,7 +222,7 @@ (!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 diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp index 3a2e8af..2353a74 100644 --- a/tests/clos.impure-cload.lisp +++ b/tests/clos.impure-cload.lisp @@ -164,3 +164,16 @@ (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)) + +;;; 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))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index de4c435..42b2ec0 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -14,7 +14,7 @@ (load "assertoid.lisp") (defpackage "CLOS-IMPURE" - (:use "CL" "ASSERTOID")) + (:use "CL" "ASSERTOID" "TEST-UTIL")) (in-package "CLOS-IMPURE") ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to @@ -1177,5 +1177,28 @@ (assert (equal (list (slot-value c1 'class-slot) (slot-value c2 'class-slot)) (list 1 1)))))) - + +;;; 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)))) + ;;;; success diff --git a/tests/mop.pure.lisp b/tests/mop.pure.lisp new file mode 100644 index 0000000..22fe7cc --- /dev/null +++ b/tests/mop.pure.lisp @@ -0,0 +1,25 @@ +;;;; 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)))) diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index e7f0964..3f8639e 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -216,4 +216,72 @@ (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") diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index b2ac327..da30191 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -354,7 +354,6 @@ (mapcar #'find-class '(simple-condition condition sb-pcl::slot-object - sb-kernel:instance t)))) ;; stream classes @@ -375,7 +374,6 @@ sb-pcl::std-object sb-pcl::slot-object stream - sb-kernel:instance t)))) (assert (equal (sb-pcl:class-precedence-list (find-class 'fundamental-stream)) @@ -383,7 +381,7 @@ 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))))) diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 3bddb5b..05e7a30 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -289,3 +289,14 @@ ACTUAL ~D DERIVED ~D~%" '(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)) diff --git a/version.lisp-expr b/version.lisp-expr index e95d9b9..b0473e6 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.4.53" +"0.9.4.54" -- 1.7.10.4