* enhancement: when a symbol name conflict error arises, the
conflicting symbols are always printed with a package prefix.
(thanks to Kevin Reid)
- * enhancement: stepping is now once again supported on the SPARC. (It is
- also now more likely to work on CheneyGC builds on the PPC.)
- * enhancement: Stepping support on MIPS.
+ * enhancement: stepping is now once again supported on the SPARC and
+ MIPS platforms. (It is also now more likely to work on CheneyGC
+ builds on the PPC.)
* enhancement: sb-sprof can now also track and report accurate call
counts.
+ * bug fixes: the treatment of non-standard subclasses of
+ SB-MOP:SPECIALIZER is more correct.
* incompatible change: PURIFY no longer copies the data from the
dynamic space into the static and read-only spaces on platforms
that use the generational garbage collector
(cond
(class
(if (typep class '(or built-in-class structure-class))
- `(type ,specializer ,parameter)
+ `(type ,class ,parameter)
;; don't declare CLOS classes as parameters;
;; it's too expensive.
'(ignorable)))
(fsc-instance-wrapper ,argument))
(t
(go ,miss-label))))
- (class
+ ;; Sep92 PCL used to distinguish between some of these cases (and
+ ;; spuriously exclude others). Since in SBCL
+ ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
+ ;; equivalent and inlined to each other, we can collapse some
+ ;; spurious differences.
+ ((class built-in-instance structure-instance condition-instance)
(when slot (error "can't do a slot reg for this metatype"))
`(wrapper-of ,argument))
- ((built-in-instance structure-instance)
- (when slot (error "can't do a slot reg for this metatype"))
- `(built-in-or-structure-wrapper
- ,argument))))
+ ;; a metatype of NIL should never be seen here, as NIL is only in
+ ;; the metatypes before a generic function is fully initialized.
+ ;; T should never be seen because we never need to get a wrapper
+ ;; to do dispatch if all methods have T as the respective
+ ;; specializer.
+ ((t nil)
+ (bug "~@<metatype ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper))))
(when (pcl-instance-p instance)
(get-slots instance)))
-(defmacro built-in-or-structure-wrapper (x) `(layout-of ,x))
-
(defmacro get-wrapper (inst)
(once-only ((wrapper `(wrapper-of ,inst)))
`(progn
(defmethod specializer-class ((specializer eql-specializer))
(class-of (slot-value specializer 'object)))
+;;; KLUDGE: this is needed to allow for user-defined specializers in
+;;; RAISE-METATYPE; however, the list of methods is maintained by
+;;; hand, which is error-prone. We can't just add a method to
+;;; SPECIALIZER-CLASS, or at least not with confidence, as that
+;;; function is used elsewhere in PCL. -- CSR, 2007-05-10
+(defmethod specializer-class-or-nil ((specializer specializer))
+ nil)
+(defmethod specializer-class-or-nil ((specializer eql-specializer))
+ (specializer-class specializer))
+(defmethod specializer-class-or-nil ((specializer class))
+ (specializer-class specializer))
+(defmethod specializer-class-or-nil ((specializer class-eq-specializer))
+ (specializer-class specializer))
+(defmethod specializer-class-or-nil ((specializer class-prototype-specializer))
+ (specializer-class specializer))
+
(defun error-need-at-least-n-args (function n)
(error 'simple-program-error
:format-control "~@<The function ~2I~_~S ~I~_requires ~
(check-wrapper-validity instance)))
\f
;;; NIL: means nothing so far, no actual arg info has NILs in the
-;;; metatype
+;;; metatype.
;;;
;;; CLASS: seen all sorts of metaclasses (specifically, more than one
;;; of the next 5 values) or else have seen something which doesn't
-;;; fall into a single category (SLOT-INSTANCE, FORWARD).
+;;; fall into a single category (SLOT-INSTANCE, FORWARD). Also used
+;;; when seen a non-standard specializer.
;;;
-;;; T: means everything so far is the class T
-;;; STANDARD-INSTANCE: seen only standard classes
-;;; BUILT-IN-INSTANCE: seen only built in classes
-;;; STRUCTURE-INSTANCE: seen only structure classes
-;;; CONDITION-INSTANCE: seen only condition classes
+;;; T: means everything so far is the class T.
+;;;
+;;; The above three are the really important ones, as they affect how
+;;; discriminating functions are computed. There are some other
+;;; possible metatypes:
+;;;
+;;; * STANDARD-INSTANCE: seen only standard classes
+;;; * BUILT-IN-INSTANCE: seen only built in classes
+;;; * STRUCTURE-INSTANCE: seen only structure classes
+;;; * CONDITION-INSTANCE: seen only condition classes
+;;;
+;;; but these are largely unexploited as of 2007-05-10. The
+;;; distinction between STANDARD-INSTANCE and the others is used in
+;;; emitting wrapper/slot-getting code in accessor discriminating
+;;; functions (see EMIT-FETCH-WRAPPER and EMIT-READER/WRITER); it is
+;;; possible that there was an intention to use these metatypes to
+;;; specialize cache implementation or discrimination nets, but this
+;;; has not occurred as yet.
(defun raise-metatype (metatype new-specializer)
(let ((slot (find-class 'slot-class))
(standard (find-class 'standard-class))
(built-in (find-class 'built-in-class))
(frc (find-class 'forward-referenced-class)))
(flet ((specializer->metatype (x)
- (let ((meta-specializer
- (if (eq *boot-state* 'complete)
- (class-of (specializer-class x))
- (class-of x))))
+ (let* ((specializer-class (if (eq *boot-state* 'complete)
+ (specializer-class-or-nil x)
+ x))
+ (meta-specializer (class-of specializer-class)))
(cond
((eq x *the-class-t*) t)
+ ((not specializer-class) 'non-standard)
((*subtypep meta-specializer standard) 'standard-instance)
((*subtypep meta-specializer fsc) 'standard-instance)
((*subtypep meta-specializer condition) 'condition-instance)
(let ((new-metatype (specializer->metatype new-specializer)))
(cond ((eq new-metatype 'slot-instance) 'class)
((eq new-metatype 'forward) 'class)
+ ((eq new-metatype 'non-standard) 'class)
((null metatype) new-metatype)
((eq metatype new-metatype) new-metatype)
(t 'class))))))
(assert (test (make-instance 'super)))
(assert (null (test (make-instance 'sub))))
+
+(let ((spec (sb-pcl::class-eq-specializer (find-class 't))))
+ (eval `(defmethod test ((x ,spec)) (class-of x))))
+
+(assert (test (make-instance 'super)))
+(assert (null (test (make-instance 'sub))))
--- /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.
+
+;;; a test of a non-standard specializer class. Some context: a
+;;; (mostly content-free) discussion on comp.lang.lisp around
+;;; 2007-05-08 about the merits of Lisp, wherein an F#/OCaml advocate
+;;; implies roughly "I've heard that CLOS is slower than pattern
+;;; matching"
+
+;;; This implements a generic function type which dispatches on
+;;; patterns in its methods. The implementation below is a simple
+;;; interpreter of patterns; compiling the patterns into a
+;;; discrimination net, or other optimized dispatch structure, would
+;;; be an interesting exercise for the reader. (As would fixing some
+;;; other marked issues).
+
+(defpackage "MOP-27"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-27")
+
+(defclass pattern-specializer (specializer)
+ ((pattern :initarg pattern :reader pattern)
+ (direct-methods :initform nil :reader specializer-direct-methods)))
+
+(defvar *pattern-specializer-table* (make-hash-table :test 'equal))
+
+(defun ensure-pattern-specializer (pattern)
+ (or (gethash pattern *pattern-specializer-table*)
+ (setf (gethash pattern *pattern-specializer-table*)
+ (make-instance 'pattern-specializer 'pattern pattern))))
+
+;;; only one arg for now
+(defclass pattern-gf/1 (standard-generic-function) ()
+ (:metaclass funcallable-standard-class))
+
+(defmethod compute-discriminating-function ((generic-function pattern-gf/1))
+ (lambda (arg)
+ (let* ((methods (generic-function-methods generic-function))
+ (function (method-interpreting-function methods generic-function)))
+ (set-funcallable-instance-function generic-function function)
+ (funcall function arg))))
+
+(defun method-interpreting-function (methods gf)
+ (lambda (arg)
+ (dolist (method methods (no-applicable-method gf (list arg)))
+ (when (matchesp arg (pattern (car (method-specializers method))))
+ (return (funcall (method-function method) (list arg) nil))))))
+
+(defun matchesp (arg pattern)
+ (cond
+ ((null pattern) t)
+ ((atom pattern) (eql arg pattern))
+ (t (and (matchesp (car arg) (car pattern))
+ (matchesp (cdr arg) (cdr pattern))))))
+
+
+;;; protocol functions. SPECIALIZER-DIRECT-METHODS is implemented by
+;;; a reader on the specializer. FIXME: implement
+;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS.
+(defmethod add-direct-method ((specializer pattern-specializer) method)
+ (pushnew method (slot-value specializer 'direct-methods)))
+(defmethod remove-direct-method ((specializer pattern-specializer) method)
+ (setf (slot-value specializer 'direct-methods)
+ (remove method (slot-value specializer 'direct-methods))))
+\f
+(defgeneric simplify (x)
+ (:generic-function-class pattern-gf/1))
+;;; KLUDGE: order of definition matters, as we simply traverse
+;;; generic-function-methods until a pattern matches our argument.
+;;; Additionally, we're not doing anything interesting with regard to
+;;; destructuring the pattern for use in the method body; a real
+;;; implementation would make it more convenient.
+(let ((specializer (ensure-pattern-specializer 'nil)))
+ (eval `(defmethod simplify ((x ,specializer)) x)))
+(let ((specializer (ensure-pattern-specializer '(* nil 0))))
+ (eval `(defmethod simplify ((x ,specializer)) 0)))
+(let ((specializer (ensure-pattern-specializer '(* 0 nil))))
+ (eval `(defmethod simplify ((x ,specializer)) 0)))
+
+(assert (eql (simplify '(* 0 3)) 0))
+(assert (eql (simplify '(* (+ x y) 0)) 0))
+(assert (equal (simplify '(+ x y)) '(+ x y)))
;;; 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".)
-"1.0.5.45"
+"1.0.5.46"
projects / sbcl.git / commitdiff