1.0.5.46: improve handling of non-standard subclasses of SB-MOP:SPECI…

…ALIZER

	... 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

@@ -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

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)))

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 ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper))))

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

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 "~@<The function ~2I~_~S ~I~_requires ~

src/pcl/wrapper.lisp

@@ -187,17 +187,31 @@
     (check-wrapper-validity instance)))
 
 ;;;  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))
@@ -207,12 +221,13 @@
         (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)
@@ -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))))))

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))))

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)))

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"