From b1a1d1280f0003e0d5af9996274c95a78f188b37 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 10 May 2007 16:00:54 +0000 Subject: [PATCH] 1.0.5.46: improve handling of non-standard subclasses of SB-MOP:SPECIALIZER ... define SPECIALIZER-CLASS-OR-NIL for use in RAISE-METATYPE, and adjust RAISE-METATYPE to handle NIL return values. ... add commentary around RAISE-METATYPE to explain what all the metatypes actually mean. ... EMIT-FETCH-WRAPPER was missing a CONDITION-INSTANCE case, and further drew fine distinctions where there were none... ... so delete BUILT-IN-OR-STRUCTURE-WRAPPER, and call WRAPPER-OF instead. (But leave in the GC safety bug reported sbcl-devel 2007-05-10.) ... one more fix to PARAMETER-SPECIALIZER-DECLARATION-IN-DEFMETHOD for CLASS-EQ specializers on built-in-classes. --- NEWS | 8 ++-- src/pcl/boot.lisp | 2 +- src/pcl/dlisp.lisp | 18 ++++++--- src/pcl/low.lisp | 2 - src/pcl/methods.lisp | 16 ++++++++ src/pcl/wrapper.lisp | 38 +++++++++++++------ tests/mop-26.impure.lisp | 6 +++ tests/mop-27.impure.lisp | 93 ++++++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 9 files changed, 162 insertions(+), 23 deletions(-) create mode 100644 tests/mop-27.impure.lisp diff --git a/NEWS b/NEWS index 516e250..af347b3 100644 --- a/NEWS +++ b/NEWS @@ -13,11 +13,13 @@ changes in sbcl-1.0.6 relative to sbcl-1.0.5: * 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 diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 384d36b..6d8c52c 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -638,7 +638,7 @@ bootstrapping. (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))) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index a3d841c..3cbdc7c 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -545,10 +545,18 @@ (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 'emit-fetch-wrapper)))) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 4ace205..a825d5c 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -260,8 +260,6 @@ (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 diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index d3186a0..d9e2ac8 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -629,6 +629,22 @@ (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 "~@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) @@ -232,6 +247,7 @@ (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)))))) diff --git a/tests/mop-26.impure.lisp b/tests/mop-26.impure.lisp index b70f923..c7a2b2b 100644 --- a/tests/mop-26.impure.lisp +++ b/tests/mop-26.impure.lisp @@ -34,3 +34,9 @@ (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)))) diff --git a/tests/mop-27.impure.lisp b/tests/mop-27.impure.lisp new file mode 100644 index 0000000..fa1835e --- /dev/null +++ b/tests/mop-27.impure.lisp @@ -0,0 +1,93 @@ +;;;; 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)))) + +(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))) diff --git a/version.lisp-expr b/version.lisp-expr index 06b09cc..521b791 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".) -"1.0.5.45" +"1.0.5.46" -- 1.7.10.4