From 1e07a36aacbbb7c9c8b7fbb4c6b2a1c5aa572b4f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 4 Dec 2024 12:02:49 +0000 Subject: [PATCH] Fix broken class tests for [FUNCALLABLE-]STANDARD-OBJECT In discriminating nets, the class tests for STANDARD-OBJECT and FUNCALLABLE-STANDARD-OBJECT used the "low"-level STD-INSTANCE-P and FSC-INSTANCE-P, which despite their names are not suitable for general use but instead admit false positive (they test for INSTANCE and FUNCALLABLE-INSTANCE respectively). This meant that they would incorrectly classify e.g. structures, conditions, and arbitrary funcallable-instances as STANDARD-OBJECT. Mostly the discriminating net code is latent. It is possible to convince it to come into play, for example in generic functions with very large numbers of required arguments, or with EQL specializers or (in some other cases) as part of a secondary dispatch function. Add some direct tests of the discriminating net code as well as implicit tests through pure "user code". Also remove some other uses of STD-INSTANCE-P and FSC-INSTANCE-P where the context makes it clear that their system-low-level equivalents should be used directly. --- NEWS | 4 ++ src/pcl/dlisp.lisp | 4 +- src/pcl/methods.lisp | 6 +- src/pcl/wrapper.lisp | 4 +- tests/clos-1.impure.lisp | 22 +++++++ tests/clos-discrimination-net.impure.lisp | 76 +++++++++++++++++++++++ 6 files changed, 109 insertions(+), 7 deletions(-) create mode 100644 tests/clos-discrimination-net.impure.lisp diff --git a/NEWS b/NEWS index e59fba852..3fdb8a0b4 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,10 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-2.4.11: + * bug fix: generic functions with a large number of required arguments, with + methods with specializations on exactly STANDARD-OBJECT or + FUNCALLABLE-STANDARD-OBJECT, test the types of their arguments more + correctly. * bug fix: defining a method on SB-MOP:SLOT-VALUE-USING-CLASS where the object argument is specialized to a CONDITION-CLASS no longer leads to an internal error. diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index e4c5e590e..aa439c35b 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -400,14 +400,14 @@ ;; instance-slots-layout instead of for-std-class-p, as if there ;; are no layouts there are no slots to worry about. (with-unique-names (wrapper) - `(cond ((std-instance-p ,argument) + `(cond ((%instancep ,argument) ,(if slots-var `(let ((,wrapper (%instance-layout ,argument))) (when (layout-for-pcl-obj-p ,wrapper) (setq ,slots-var (std-instance-slots ,argument))) ,wrapper) `(%instance-layout ,argument))) - ((fsc-instance-p ,argument) + ((function-with-layout-p ,argument) ,(if slots-var `(let ((,wrapper (%fun-layout ,argument))) (when (layout-for-pcl-obj-p ,wrapper) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 0e4306957..b0b54035e 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1103,13 +1103,13 @@ (cond ((eq class *the-class-t*) t) ((eq class *the-class-standard-object*) - `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) + `(pcl-instance-p ,arg)) ((eq class *the-class-funcallable-standard-object*) - `(fsc-instance-p ,arg)) + `(and (pcl-instance-p ,arg) (fsc-instance-p ,arg))) ;; This is going to be cached (in *fgens*), ;; and structure type tests do not check for invalid layout. ;; Cache the wrapper itself, which is going to be different after - ;; redifinition. + ;; redefinition. ((structure-class-p class) `(sb-c::%instance-typep ,arg ,(class-wrapper class))) (t diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index 2a6c0f3c6..7b7301492 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -249,9 +249,9 @@ (let ((new (the layout (cdr state)))) (ecase (car state) (:flush - (cond ((std-instance-p instance) + (cond ((%instancep instance) (setf (%instance-layout instance) new)) - ((fsc-instance-p instance) + ((function-with-layout-p instance) (setf (%fun-layout instance) new)) (t (bug "unrecognized instance type")))) diff --git a/tests/clos-1.impure.lisp b/tests/clos-1.impure.lisp index b8850bfac..3b3d1196d 100644 --- a/tests/clos-1.impure.lisp +++ b/tests/clos-1.impure.lisp @@ -407,3 +407,25 @@ (let ((string (with-output-to-string (s) (example-method-combination-order-nil-gf t s)))) (assert (string= string "1: T and 2: T")))) + +(defmethod one-required-argument ((x standard-object)) + (list x)) +(defmethod one-required-argument ((x t)) + (list t)) +(with-test (:name :one-required-argument-standard-object-not-just-instance) + (assert (equal (one-required-argument #'one-required-argument) + (list #'one-required-argument))) + (assert (equal (one-required-argument #p"") (list t))) + (assert (equal (one-required-argument (make-condition 'error)) (list t)))) + +(defmethod many-required-arguments ((x standard-object) a b c d e f g h i &rest args) + (cons x args)) +(defmethod many-required-arguments ((x t) a b c d e f g h i &rest args) + args) +(with-test (:name :many-required-arguments-standard-object-not-just-instance) + (assert (equal (many-required-arguments #'many-required-arguments 1 2 3 4 5 6 7 8 9 10 11 12) + (list #'many-required-arguments 10 11 12))) + (assert (equal (many-required-arguments #p"" 1 2 3 4 5 6 7 8 9 10 11 12) + (list 10 11 12))) + (assert (equal (many-required-arguments (make-condition 'error) 1 2 3 4 5 6 7 8 9 10 11 12) + (list 10 11 12)))) diff --git a/tests/clos-discrimination-net.impure.lisp b/tests/clos-discrimination-net.impure.lisp new file mode 100644 index 000000000..345541b1f --- /dev/null +++ b/tests/clos-discrimination-net.impure.lisp @@ -0,0 +1,76 @@ +;;;; testing clos discrimination nets + +;;;; 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. + +(defgeneric foo (x)) +(defmethod foo ((x t)) (list t x)) +(defmethod foo ((x standard-object)) (list 'standard-object x)) +(defmethod foo ((x sb-mop:funcallable-standard-object)) + (list 'sb-mop:funcallable-standard-object x)) + +(defvar *fun* + (let* ((net (sb-pcl::generate-discrimination-net + #'foo (sb-mop:generic-function-methods #'foo) nil nil)) + (form `(lambda (sb-pcl::.arg0.) + (macrolet ((sb-pcl::methods ((&rest ms) (&rest types)) + (declare (ignore types)) + (let (result) + (dolist (m ms) + (let ((f (sb-mop:method-function m))) + (push `(funcall ,f (list sb-pcl::.arg0.) nil) result))) + `(list ,@(nreverse result))))) + ,net)))) + (compile nil form))) + +(with-test (:name :standard-cases) + (assert (equal (foo 1) (list t 1))) + (assert (equal (funcall *fun* 1) (list (list t 1)))) + (assert (equal (foo (find-class 'standard-method)) (list 'standard-object (find-class 'standard-method)))) + (assert (equal (funcall *fun* (find-class 'standard-method)) + (list (list 'standard-object (find-class 'standard-method)) + (list t (find-class 'standard-method))))) + (assert (equal (foo #'foo) (list 'sb-mop:funcallable-standard-object #'foo))) + (assert (equal (funcall *fun* #'foo) + (list (list 'sb-mop:funcallable-standard-object #'foo) + (list 'standard-object #'foo) + (list t #'foo))))) + +(with-test (:name :pathname-not-standard-object) + (let ((pathname #p"")) + (assert (not (typep pathname 'standard-object))) + (assert (equal (foo pathname) (list t pathname))) + (assert (equal (funcall *fun* pathname) (list (list t pathname)))))) + +(defstruct s a) + +(with-test (:name :struct-not-standard-object) + (let ((struct (make-s :a 3))) + (assert (not (typep struct 'standard-object))) + (assert (equal (foo struct) (list t struct))) + (assert (equal (funcall *fun* struct) (list (list t struct)))))) + +(with-test (:name :condition-not-standard-object) + (let ((condition (make-condition 'style-warning))) + (assert (not (typep condition 'standard-object))) + (assert (equal (foo condition) (list t condition))) + (assert (equal (funcall *fun* condition) (list (list t condition)))))) + +;;; %METHOD-FUNCTION is a useful FUNCALLABLE-INSTANCE that is +;;; known not to be a FUNCALLABLE-STANDARD-OBJECT, and is available in +;;; every build configuration. +(with-test (:name :method-fast-function-not-funcallable-standard-object) + (let* ((method (find-method #'foo nil (list (find-class t)))) + (method-function (sb-mop:method-function method))) + (assert (not (typep method-function 'sb-mop:funcallable-standard-object))) + (assert (typep method-function 'sb-pcl::%method-function)) + (assert (equal (foo method-function) (list t method-function))) + (assert (equal (funcall *fun* method-function) (list (list t method-function))))))