master: Make sure TYPE-ERRORs have valid DATUM and EXPECTED-TYPE
crhodes via Sbcl-commits <[email protected]> Tue, 05 May 2026 20:39:27 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via ec1f07e79ac25d31a485eb38d389e27eecbbb441 (commit)
from c7b985482ab1db2efa403a846073b3759dd61adb (commit)
- Log -----------------------------------------------------------------
commit ec1f07e79ac25d31a485eb38d389e27eecbbb441
Author: Christophe Rhodes <[email protected]>
Date: Tue May 5 20:47:06 2026 +0100
Make sure TYPE-ERRORs have valid DATUM and EXPECTED-TYPE
We should not make generalized instances of TYPE-ERROR with unbound
DATUM or EXPECTED-TYPE, or where the DATUM is actually of type
EXPECTED-TYPE. With #+sb-devel, provide a special variable to check
for mismatch when creating the condition, and turn that switch on when
running tests.
Fix the issues that this reveals:
- in sequence-related code, make sure any errors relating to the
length mismatch between expressed type and sequence length have a
precise size if appropriate.
- also in sequence-related code, special-case the NIL sequence type
specifier, which is a recognizable subtype of LIST and VECTOR and
yet not a good type for making sequences.
(arguably the type error that the standard "expects" us to signal
for the bad cases of MAKE-SEQUENCE and friends is that the
constructed sequence is not of the type given by the type specifier,
rather than that the type specifier is not of some strange
VALID-MAKE-SEQUENCE-TYPE-SPECIFIER type. However, that's not what
we currently have.)
- in stream-related code, make new predicates for
{BINARY,CHARACTER}-{INPUT-OUTPUT}-STREAM-P and use them in the ILL-X
stream functions.
- make the PCL-internal MISSING-SLOT condition not be a TYPE-ERROR.
- make accessing an uninitialized structure slot, from &AUX arguments
in BOA constructors with no defaults, not be a type error (according
to the standard, accessing an uninitialized slot is undefined
behaviour).
---
NEWS | 4 ++++
contrib/sb-simple-streams/impl.lisp | 14 +++++++++++++
src/code/interr.lisp | 18 +++-------------
src/code/seq.lisp | 13 ++++++++----
src/code/stream.lisp | 32 +++++++++++++++++++++++++----
src/code/target-error.lisp | 16 +++++++++++++++
src/cold/exports.lisp | 2 ++
src/compiler/fndb.lisp | 4 ++++
src/pcl/gray-streams-class.lisp | 5 +++++
src/pcl/gray-streams.lisp | 41 +++++++++++++++++++++++--------------
src/pcl/slots.lisp | 2 +-
tests/defstruct.impure.lisp | 35 ++++++++++---------------------
tests/run-tests.lisp | 1 +
13 files changed, 124 insertions(+), 63 deletions(-)
diff --git a/NEWS b/NEWS
index 343133cdf..c2383af42 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,10 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-2.6.4:
+ * minor incompatible change: the condition signalled when an accessed slot
+ is missing from an object is no longer a TYPE-ERROR.
+ * minor incompatible change: the condition signalled when accessing an
+ uninitialized structure slot is no longer a TYPE-ERROR.
* bug fix: strings of arbitrary size with fill-pointer set to 1 are
character designators. (reported by _death)
diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp
index e6bf4da7b..2267ea75b 100644
--- a/contrib/sb-simple-streams/impl.lisp
+++ b/contrib/sb-simple-streams/impl.lisp
@@ -47,6 +47,20 @@
(defmethod output-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :output))
+(defmethod sb-int:binary-input-stream-p ((stream simple-stream))
+ (and (any-stream-instance-flags stream :input)
+ (not (any-stream-instance-flags stream :string))))
+
+(defmethod sb-int:binary-output-stream-p ((stream simple-stream))
+ (and (any-stream-instance-flags stream :output)
+ (not (any-stream-instance-flags stream :string))))
+
+(defmethod sb-int:character-input-stream-p ((stream simple-stream))
+ (any-stream-instance-flags stream :input))
+
+(defmethod sb-int:character-output-stream-p ((stream simple-stream))
+ (any-stream-instance-flags stream :output))
+
(defmethod open-stream-p ((stream simple-stream))
(any-stream-instance-flags stream :input :output))
diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index 759374965..2a9441941 100644
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -678,22 +678,10 @@
(< error-number (length sb-c:+backend-internal-errors+)))
(let ((context (sb-di:error-context)))
(if (typep context '(cons (eql struct-read-context)))
- ;; This was shoehorned into being a "type error"
- ;; which isn't the best way to explain it to the user.
- ;; However, from an API stance, it makes some sense to signal
- ;; a TYPE-ERROR since there may be existing code that catches
- ;; unbound slots errors as type-errors. Our tests certainly do,
- ;; but perhaps only as an artifact of the implementation.
(destructuring-bind (struct-name . slot-name) (cdr context)
- ;; Infer the slot type, but fail safely. The message is enough,
- ;; and the required type is pretty much irrelevant.
- (let* ((dd (find-defstruct-description struct-name))
- (dsd (and dd (find slot-name (dd-slots dd) :key #'dsd-name))))
- (error 'simple-type-error
- :format-control "Accessed uninitialized slot ~S of structure ~S"
- :format-arguments (list slot-name struct-name)
- :datum (make-unbound-marker)
- :expected-type (if dsd (dsd-type dsd) 't))))
+ (error 'simple-error
+ :format-control "Accessed uninitialized slot ~S of structure ~S"
+ :format-arguments (list slot-name struct-name)))
(object-not-type-error (sb-di::sub-access-debug-var-slot
fp (first arguments) alien-context)
(car (svref sb-c:+backend-internal-errors+
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 90f9b673e..dcf03597e 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -237,7 +237,11 @@
((type= type (specifier-type 'null))
'(eql 0))
((cons-type-p type)
- '(integer 1))
+ (multiple-value-bind (min exactp)
+ (sb-kernel::cons-type-length-info type)
+ (if exactp
+ `(integer ,min ,min)
+ `(integer ,min))))
(t (bug "weird type in S-T-L-M-ERROR")))
;; FIXME: this format control causes ugly printing. There's
;; probably some ~<~@:_~> incantation that would make it
@@ -283,9 +287,10 @@
(defun is-a-valid-sequence-type-specifier-p (type)
(let ((type (specifier-type type)))
- (or (csubtypep type (specifier-type 'list))
- (and (csubtypep type (specifier-type 'vector))
- (not (csubtypep type (specifier-type '(and vector (not simple-array)))))))))
+ (and (not (csubtypep type (specifier-type 'nil)))
+ (or (csubtypep type (specifier-type 'list))
+ (and (csubtypep type (specifier-type 'vector))
+ (not (csubtypep type (specifier-type '(and vector (not simple-array))))))))))
(declaim (ftype (function (sequence index) nil) signal-index-too-large-error))
(define-error-wrapper signal-index-too-large-error (sequence index)
diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index df586190e..8613ec589 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -62,28 +62,28 @@
(declare (ignore ignore))
(error 'simple-type-error
:datum stream
- :expected-type '(satisfies input-stream-p)
+ :expected-type '(satisfies character-input-stream-p)
:format-control "~S is not a character input stream."
:format-arguments (list stream)))
(defun ill-out (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
:datum stream
- :expected-type '(satisfies output-stream-p)
+ :expected-type '(satisfies character-output-stream-p)
:format-control "~S is not a character output stream."
:format-arguments (list stream)))
(defun ill-bin (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
:datum stream
- :expected-type '(satisfies input-stream-p)
+ :expected-type '(satisfies binary-input-stream-p)
:format-control "~S is not a binary input stream."
:format-arguments (list stream)))
(defun ill-bout (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
:datum stream
- :expected-type '(satisfies output-stream-p)
+ :expected-type '(satisfies binary-output-stream-p)
:format-control "~S is not a binary output stream."
:format-arguments (list stream)))
(defun closed-flame (stream &rest ignore)
@@ -122,6 +122,18 @@
(or (not (eq (ansi-stream-in stream) #'ill-in))
(not (eq (ansi-stream-bin stream) #'ill-bin))))))
+(defmethod binary-input-stream-p ((stream ansi-stream))
+ (if (synonym-stream-p stream)
+ (binary-input-stream-p (resolve-synonym-stream stream))
+ (and (not (eq (ansi-stream-bin stream) #'closed-flame))
+ (not (eq (ansi-stream-bin stream) #'ill-bin)))))
+
+(defmethod character-input-stream-p ((stream ansi-stream))
+ (if (synonym-stream-p stream)
+ (character-input-stream-p (resolve-synonym-stream stream))
+ (and (not (eq (ansi-stream-in stream) #'closed-flame))
+ (not (eq (ansi-stream-in stream) #'ill-in)))))
+
(defmethod output-stream-p ((stream ansi-stream))
(if (synonym-stream-p stream)
(output-stream-p (resolve-synonym-stream stream))
@@ -129,6 +141,18 @@
(or (not (eq (ansi-stream-cout stream) #'ill-out))
(not (eq (ansi-stream-bout stream) #'ill-bout))))))
+(defmethod binary-output-stream-p ((stream ansi-stream))
+ (if (synonym-stream-p stream)
+ (binary-output-stream-p (resolve-synonym-stream stream))
+ (and (not (eq (ansi-stream-bout stream) #'closed-flame))
+ (not (eq (ansi-stream-bout stream) #'ill-bout)))))
+
+(defmethod character-output-stream-p ((stream ansi-stream))
+ (if (synonym-stream-p stream)
+ (character-output-stream-p (resolve-synonym-stream stream))
+ (and (not (eq (ansi-stream-cout stream) #'closed-flame))
+ (not (eq (ansi-stream-cout stream) #'ill-out)))))
+
(defmethod open-stream-p ((stream ansi-stream))
;; CLHS 21.1.4 lets us not worry about synonym streams here.
(let ((in (ansi-stream-in stream)))
diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index a03fe3c9c..936f1e94d 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -452,6 +452,9 @@ with that condition (or with no condition) will be returned."
(when (eq (%instance-ref condition i) 'dx-object-type)
(return (%instance-ref condition (1+ i))))))
+#+sb-devel
+(defvar *check-type-error-consistency* nil)
+
(defun make-condition (type &rest initargs)
"Make an instance of a condition object using the specified initargs."
;; Note: While ANSI specifies no exceptional situations in this function,
@@ -485,6 +488,19 @@ with that condition (or with no condition) will be returned."
(find-slot-default condition classoid hslot))
(condition-assigned-slots condition))))
+ #+sb-devel
+ (when (and *check-type-error-consistency* (typep condition 'type-error))
+ (let* ((expected-type (type-error-expected-type condition))
+ (typecheckfun (compile nil `(lambda (x)
+ (declare (optimize safety))
+ (the ,expected-type x)))))
+ (handler-case
+ (let ((*check-type-error-consistency* nil))
+ (funcall typecheckfun (type-error-datum condition)))
+ (type-error ())
+ (:no-error (x)
+ (bug "DATUM ~S is of EXPECTED-TYPE ~S" x expected-type)))))
+
condition))
;;;; DEFINE-CONDITION
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index f5d0c1a93..55c93ca5b 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -581,6 +581,8 @@ possibly temporarily, because it might be used internally.")
;; error-reporting facilities
+ "BINARY-INPUT-STREAM-P" "BINARY-OUTPUT-STREAM-P"
+ "CHARACTER-INPUT-STREAM-P" "CHARACTER-OUTPUT-STREAM-P"
"CLOSED-STREAM-ERROR" "CLOSED-SAVED-STREAM-ERROR"
"COMPILED-PROGRAM-ERROR"
"COMPILER-MACRO-KEYWORD-PROBLEM"
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 6ed77011c..920c30875 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1624,6 +1624,10 @@
(defknown stream-external-format (stream) t (flushable))
(defknown (output-stream-p input-stream-p) (stream) boolean
(movable foldable flushable))
+(defknown (binary-input-stream-p binary-output-stream-p) (stream) boolean
+ (movable foldable flushable))
+(defknown (character-input-stream-p character-output-stream-p) (stream) boolean
+ (movable foldable flushable))
(defknown open-stream-p (stream) boolean (flushable))
(defknown close (stream &key (:abort t)) (eql t) ())
(defknown file-string-length (stream (or string character))
diff --git a/src/pcl/gray-streams-class.lisp b/src/pcl/gray-streams-class.lisp
index 06d487eee..160224c96 100644
--- a/src/pcl/gray-streams-class.lisp
+++ b/src/pcl/gray-streams-class.lisp
@@ -48,6 +48,11 @@ is a subtype of unsigned-byte or signed-byte."))
(fundamental-output-stream fundamental-binary-stream) nil
(:documentation "Superclass of all Gray output streams whose element-type
is a subtype of unsigned-byte or signed-byte."))
+
+;;; Ensure that classes are finalized here so that our bootstrap does
+;;; not populate PCL method caches with layouts that are later
+;;; invalidated by lazy class finalization.
+(sb-pcl::map-all-classes #'sb-mop:finalize-inheritance (find-class 'fundamental-stream))
;;; This is not in the Gray stream proposal, so it is left here
;;; as example code.
diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp
index ac2ec97c7..49472a7a5 100644
--- a/src/pcl/gray-streams.lisp
+++ b/src/pcl/gray-streams.lisp
@@ -57,29 +57,40 @@
(progn
(!def-stream-generic input-stream-p (stream)
(:documentation "Can STREAM perform input operations?"))
-
- (defmethod input-stream-p ((stream fundamental-stream))
- nil)
-
- (defmethod input-stream-p ((stream fundamental-input-stream))
- t))
+ (defmethod input-stream-p ((stream fundamental-stream)) nil)
+ (defmethod input-stream-p ((stream fundamental-input-stream)) t))
(progn
(!def-stream-generic interactive-stream-p (stream)
(:documentation "Is STREAM an interactive stream?"))
-
- (defmethod interactive-stream-p ((stream fundamental-stream))
- nil))
+ (defmethod interactive-stream-p ((stream fundamental-stream)) nil))
(progn
(!def-stream-generic output-stream-p (stream)
(:documentation "Can STREAM perform output operations?"))
-
- (defmethod output-stream-p ((stream fundamental-stream))
- nil)
-
- (defmethod output-stream-p ((stream fundamental-output-stream))
- t))
+ (defmethod output-stream-p ((stream fundamental-stream)) nil)
+ (defmethod output-stream-p ((stream fundamental-output-stream)) t))
+
+(progn
+ (!def-stream-generic binary-input-stream-p (stream)
+ (:documentation "Does STREAM perform binary input operations?"))
+ (defmethod binary-input-stream-p ((stream fundamental-stream)) nil)
+ (defmethod binary-input-stream-p ((stream fundamental-binary-input-stream)) t))
+(progn
+ (!def-stream-generic binary-output-stream-p (stream)
+ (:documentation "Does STREAM perform binary output operations?"))
+ (defmethod binary-output-stream-p ((stream fundamental-stream)) nil)
+ (defmethod binary-output-stream-p ((stream fundamental-binary-output-stream)) t))
+(progn
+ (!def-stream-generic character-input-stream-p (stream)
+ (:documentation "Does STREAM perform character input operations?"))
+ (defmethod character-input-stream-p ((stream fundamental-stream)) nil)
+ (defmethod character-input-stream-p ((stream fundamental-character-input-stream)) t))
+(progn
+ (!def-stream-generic character-output-stream-p (stream)
+ (:documentation "Does STREAM perform character output operations?"))
+ (defmethod character-output-stream-p ((stream fundamental-stream)) nil)
+ (defmethod character-output-stream-p ((stream fundamental-character-output-stream)) t))
;;; character input streams
;;;
diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 9e9eb7a0a..1122cd087 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -42,7 +42,7 @@
(cell-error-name condition)
(type-of (unbound-slot-instance condition))))))))
-(define-condition missing-slot (cell-error simple-type-error)
+(define-condition missing-slot (cell-error simple-condition)
())
;;; These three functions work on std-instances and fsc-instances. These are
diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 805d95096..9097bcb08 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -46,7 +46,7 @@
(let ((s (make-boa-saux)))
(locally (declare (optimize (safety 3))
(inline boa-saux-a))
- (assert-error (opaque-identity (boa-saux-a s)) type-error))
+ (assert-error (opaque-identity (boa-saux-a s))))
(setf (boa-saux-a s) 1)
(setf (boa-saux-c s) 5)
(assert (eql (boa-saux-a s) 1))
@@ -55,13 +55,9 @@
(with-test (:name :defstruct-boa-nice-error :skipped-on :interpreter)
(let ((err (nth-value 1 (ignore-errors (boa-saux-a (make-boa-saux))))))
- (assert (and (typep err 'simple-type-error)
- (search "Accessed uninitialized slot"
- (simple-condition-format-control err))))))
-
- ; these two checks should be
- ; kept separated
-
+ (assert (search "Accessed uninitialized slot"
+ (simple-condition-format-control err)))))
+;;; these two checks should be kept separated
(with-test (:name :defstruct-boa-no-error :skipped-on :interpreter)
(let ((s (make-boa-saux)))
(locally (declare (optimize (safety 0))
@@ -77,7 +73,7 @@
(let ((s (make-boa-saux)))
(locally (declare (optimize (safety 3))
(notinline boa-saux-a))
- (assert-error (opaque-identity (boa-saux-a s)) type-error))
+ (assert-error (opaque-identity (boa-saux-a s))))
(setf (boa-saux-a s) 1)
(setf (boa-saux-c s) 5)
(assert (eql (boa-saux-a s) 1))
@@ -1162,21 +1158,12 @@ redefinition."
(with-test (:name :bug-3b)
(handler-case
- (progn
- (bug-3b-slot (make-bug-3b))
- (error "fail"))
- (type-error (e)
- (assert (eq 'string (type-error-expected-type e)))
- ;; This next ASSERT made no sense whatsoever. If the slot named DATUM
- ;; in the ERROR instance that's reporting the unbound slot in the BUG-3B
- ;; instance is itself unbound, then how can you expect that reading the
- ;; DATUM slot in E is supposed to work?
- ;; It worked only by accident, because the first access to the slot would
- ;; return it from the initargs without checking for unbound-marker,
- ;; but a subsequent access would trap on the memoized value.
- ;; That dubious distinction is gone.
- ;; (assert (sb-int:unbound-marker-p (type-error-datum e)))
- (assert (not (slot-boundp e 'sb-kernel::datum))))))
+ (bug-3b-slot (make-bug-3b))
+ ;; not required to be a TYPE-ERROR: and there's no sensible value
+ ;; that can be given for TYPE-ERROR-DATUM.
+ (error (e)
+ (assert (search "uninitialized" (format nil "~A" e))))
+ (:no-error (c) (error "No error on read of uninitialized structure slot: ~S" c))))
(with-test (:name :defstruct-copier-typechecks-argument)
(copy-person (make-astronaut :name "Neil"))
diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index ced686994..7e85bceb5 100644
--- a/tests/run-tests.lisp
+++ b/tests/run-tests.lisp
@@ -608,6 +608,7 @@
#+gc-verify "--eval" #+gc-verify "(push :gc-verify *features*)"
#+slow "--eval" #+slow "(push :slow *features*)"
#+coverage "--eval" #+coverage "(push :coverage *features*)"
+ #+sb-devel "--eval" #+sb-devel "(setf sb-kernel::*check-type-error-consistency* t)"
"--load" load
"--eval" (write-to-string eval
:right-margin 1000))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL