common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix broken class tests for [FUNCALLABLE-]STANDARD-OBJECT

Browse source 
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.
This commit is contained in:
Christophe Rhodes 2024-12-04 12:02:49 +00:00
parent 06d3ca8794
commit 1e07a36aac
6 changed files with 109 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
NEWS
View file

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

4
src/pcl/dlisp.lisp
View file

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

6
src/pcl/methods.lisp
View file

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

4
src/pcl/wrapper.lisp
View file

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

22
tests/clos-1.impure.lisp
View file

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

76
tests/clos-discrimination-net.impure.lisp Normal file
View file

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