From 8b0f847a56feacdfcbc8dae20cdc84bb91bf4c98 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Wed, 7 Jan 2004 09:10:32 +0000 Subject: [PATCH] 0.8.7.8: * Fix argument type checking in =, /=, <, <=, >, >=, PEEK-CHAR. (reported by Peter Graves). --- BUGS | 8 ++++++++ NEWS | 4 ++++ src/code/numbers.lisp | 11 ++++++----- src/code/stream.lisp | 1 + tests/compiler.impure.lisp | 20 ++++++++++++++++++++ tests/compiler.pure.lisp | 3 ++- 6 files changed, 41 insertions(+), 6 deletions(-) diff --git a/BUGS b/BUGS index 0b8a677..14cd32a 100644 --- a/BUGS +++ b/BUGS @@ -1242,3 +1242,11 @@ WORKAROUND: function %THROW, unknown values stack after the call is empty, so the unknown values LVAR (*) is considered to be dead after the call and, thus, before it and is popped by the stack analysis. + +300: (reported by Peter Graves) Function PEEK-CHAR checks PEEK-TYPE + argument type only after having read a character. This is caused + with EXPLICIT-CHECK attribute in DEFKNOWN. The similar problem + exists with =, /=, <, >, <=, >=. They were fixed, but it is probably + less error prone to have EXPLICIT-CHECK be a local declaration, + being put into the definition, instead of an attribute being kept in + a separate file; maybe also put it into SB-EXT? diff --git a/NEWS b/NEWS index b2cc20b..8d79df5 100644 --- a/NEWS +++ b/NEWS @@ -2239,6 +2239,10 @@ changes in sbcl-0.8.8 relative to sbcl-0.8.7: (thanks to Vincent Arkesteijn) * optimization: implemented multiplication as a modular (UNSIGNED-BYTE 32) operation on the x86 backend. + * bug fix: functions =, /=, <, <=, >, >= did not check the argument + type when called with 1 argument; PEEK-CHAR checked type of + PEEK-TYPE only after having read first character from a + stream. (reported by Peter Graves) planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index c62f864..a18b5b9 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -708,6 +708,7 @@ (defun = (number &rest more-numbers) #!+sb-doc "Return T if all of its arguments are numerically equal, NIL otherwise." + (the number number) (do ((nlist more-numbers (cdr nlist))) ((atom nlist) T) (declare (list nlist)) @@ -716,7 +717,7 @@ (defun /= (number &rest more-numbers) #!+sb-doc "Return T if no two of its arguments are numerically equal, NIL otherwise." - (do* ((head number (car nlist)) + (do* ((head (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -729,7 +730,7 @@ (defun < (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly increasing order, NIL otherwise." - (do* ((n number (car nlist)) + (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -738,7 +739,7 @@ (defun > (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly decreasing order, NIL otherwise." - (do* ((n number (car nlist)) + (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -747,7 +748,7 @@ (defun <= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-decreasing order, NIL otherwise." - (do* ((n number (car nlist)) + (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) @@ -756,7 +757,7 @@ (defun >= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-increasing order, NIL otherwise." - (do* ((n number (car nlist)) + (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 77c29bc..f39c4f5 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -332,6 +332,7 @@ eof-value recursive-p) (declare (ignore recursive-p)) + (the (or character boolean) peek-type) (let ((stream (in-synonym-of stream))) (cond ((typep stream 'echo-stream) (echo-misc stream diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 18622e1..6e4ee6d 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -871,6 +871,26 @@ (truncate (expt a b)))) (assert (equal (multiple-value-list (expt-derive-type-bug 1 1)) '(1 0))) + +;;; Problems with type checking in functions with EXPLICIT-CHECK +;;; attribute (reported by Peter Graves) +(loop for (fun . args) in '((= a) (/= a) + (< a) (<= a) (> a) (>= a)) + do (assert (raises-error? (apply fun args) type-error))) + +(defclass broken-input-stream (sb-gray:fundamental-input-stream) ()) +(defmethod sb-gray:stream-read-char ((stream broken-input-stream)) + (throw 'break :broken)) +(assert (eql (block return + (handler-case + (catch 'break + (funcall (eval ''peek-char) + 1 (make-instance 'broken-input-stream)) + :test-broken) + (type-error (c) + (return-from return :good)))) + :good)) + ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 4a0bf41..9a08b7e 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1031,4 +1031,5 @@ (compilation-speed 1))) (logand a (* a 438810)))) 215067723) - 13739018)) \ No newline at end of file + 13739018)) + -- 1.7.10.4