From 4c4635c16dc6fb5fcc6adbaea9fba756083c04a2 Mon Sep 17 00:00:00 2001 From: Brian Mastenbrook Date: Fri, 12 Aug 2005 02:37:13 +0000 Subject: [PATCH] 0.9.3.45: more ANSI test fixes * SUBTYPEP-FUNCTION.(1-4) now pass * READ-BYTE and WRITE-BYTE no longer take stream designators, just streams (fixes READ-BYTE.ERROR.5 and WRITE-BYTE.ERROR.4) * Found when reading COMPLEX types code, and in ansi-tests as MISC.580: (typep #c(1 2) '(and ratio (not fixnum))) -> error Astute log-watchers will note that the version in the commit message for my last commit was wrong. When I started that tree it was 0.9.3.41, but somebody else stole that number in the meantime. I fixed version.lisp-expr, but not my own brain. Oops :-) --- src/code/late-type.lisp | 94 +++++++++++++++++++++++------------------------ src/code/stream.lisp | 19 +++++----- src/code/sysmacs.lisp | 8 +++- version.lisp-expr | 2 +- 4 files changed, 61 insertions(+), 62 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index abf2e8d..785749f 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -196,7 +196,7 @@ (!cold-init-forms (setq *unparse-fun-type-simplify* nil)) (!define-type-method (function :negate) (type) - (error "NOT FUNCTION too confusing on ~S" (type-specifier type))) + (make-negation-type :type type)) (!define-type-method (function :unparse) (type) (if *unparse-fun-type-simplify* @@ -1739,55 +1739,51 @@ (if (csubtypep component-type (specifier-type '(eql 0))) *empty-type* (modified-numeric-type component-type - :complexp :complex)))) + :complexp :complex))) + (do-complex (ctype) + (cond + ((eq ctype *empty-type*) *empty-type*) + ((eq ctype *universal-type*) (not-real)) + ((typep ctype 'numeric-type) (complex1 ctype)) + ((typep ctype 'union-type) + (apply #'type-union + (mapcar #'do-complex (union-type-types ctype)))) + ((typep ctype 'member-type) + (apply #'type-union + (mapcar (lambda (x) (do-complex (ctype-of x))) + (member-type-members ctype)))) + ((and (typep ctype 'intersection-type) + ;; FIXME: This is very much a + ;; not-quite-worst-effort, but we are required to do + ;; something here because of our representation of + ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must + ;; allow users to ask about (COMPLEX RATIO). This + ;; will of course fail to work right on such types + ;; as (AND INTEGER (SATISFIES ZEROP))... + (let ((numbers (remove-if-not + #'numeric-type-p + (intersection-type-types ctype)))) + (and (car numbers) + (null (cdr numbers)) + (eq (numeric-type-complexp (car numbers)) :real) + (complex1 (car numbers)))))) + (t + (multiple-value-bind (subtypep certainly) + (csubtypep ctype (specifier-type 'real)) + (if (and (not subtypep) certainly) + (not-real) + ;; ANSI just says that TYPESPEC is any subtype of + ;; type REAL, not necessarily a NUMERIC-TYPE. In + ;; particular, at this point TYPESPEC could legally + ;; be a hairy type like (AND NUMBER (SATISFIES + ;; REALP) (SATISFIES ZEROP)), in which case we fall + ;; through the logic above and end up here, + ;; stumped. + (bug "~@<(known bug #145): The type ~S is too hairy to be ~ +used for a COMPLEX component.~:@>" + typespec))))))) (let ((ctype (specifier-type typespec))) - (cond - ((eq ctype *empty-type*) *empty-type*) - ((eq ctype *universal-type*) (not-real)) - ((typep ctype 'numeric-type) (complex1 ctype)) - ((typep ctype 'union-type) - (apply #'type-union - ;; FIXME: This code could suffer from (admittedly - ;; very obscure) cases of bug 145 e.g. when TYPE - ;; is - ;; (OR (AND INTEGER (SATISFIES ODDP)) - ;; (AND FLOAT (SATISFIES FOO)) - ;; and not even report the problem very well. - (mapcar #'complex1 (union-type-types ctype)))) - ((typep ctype 'member-type) - (apply #'type-union - (mapcar (lambda (x) (complex1 (ctype-of x))) - (member-type-members ctype)))) - ((and (typep ctype 'intersection-type) - ;; FIXME: This is very much a - ;; not-quite-worst-effort, but we are required to do - ;; something here because of our representation of - ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must - ;; allow users to ask about (COMPLEX RATIO). This - ;; will of course fail to work right on such types - ;; as (AND INTEGER (SATISFIES ZEROP))... - (let ((numbers (remove-if-not - #'numeric-type-p - (intersection-type-types ctype)))) - (and (car numbers) - (null (cdr numbers)) - (eq (numeric-type-complexp (car numbers)) :real) - (complex1 (car numbers)))))) - (t - (multiple-value-bind (subtypep certainly) - (csubtypep ctype (specifier-type 'real)) - (if (and (not subtypep) certainly) - (not-real) - ;; ANSI just says that TYPESPEC is any subtype of - ;; type REAL, not necessarily a NUMERIC-TYPE. In - ;; particular, at this point TYPESPEC could legally - ;; be a hairy type like (AND NUMBER (SATISFIES - ;; REALP) (SATISFIES ZEROP)), in which case we fall - ;; through the logic above and end up here, - ;; stumped. - (bug "~@<(known bug #145): The type ~S is too hairy to be ~ - used for a COMPLEX component.~:@>" - typespec))))))))) + (do-complex ctype))))) ;;; If X is *, return NIL, otherwise return the bound, which must be a ;;; member of TYPE or a one-element list of a member of TYPE. diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 1f43db7..a8a1350 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -371,14 +371,13 @@ (done-with-fast-read-byte)))) (defun read-byte (stream &optional (eof-error-p t) eof-value) - (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (ansi-stream-read-byte stream eof-error-p eof-value nil) - ;; must be Gray streams FUNDAMENTAL-STREAM - (let ((char (stream-read-byte stream))) - (if (eq char :eof) - (eof-or-lose stream eof-error-p eof-value) - char))))) + (if (ansi-stream-p stream) + (ansi-stream-read-byte stream eof-error-p eof-value nil) + ;; must be Gray streams FUNDAMENTAL-STREAM + (let ((char (stream-read-byte stream))) + (if (eq char :eof) + (eof-or-lose stream eof-error-p eof-value) + char)))) ;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the ;;; number of bytes read. @@ -596,8 +595,8 @@ nil) (defun write-byte (integer stream) - (with-out-stream stream (ansi-stream-bout integer) - (stream-write-byte integer)) + (with-out-stream/no-synonym stream (ansi-stream-bout integer) + (stream-write-byte integer)) integer) diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index a970eef..e0ea5af 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -99,8 +99,8 @@ waits until gc is enabled in this thread." `(,function stream ,@args))))) `(funcall (,slot stream) stream ,@args)))) -(defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch) - `(let ((stream (out-synonym-of ,stream))) +(defmacro with-out-stream/no-synonym (stream (slot &rest args) &optional stream-dispatch) + `(let ((stream ,stream)) ,(if stream-dispatch `(if (ansi-stream-p stream) (funcall (,slot stream) stream ,@args) @@ -108,6 +108,10 @@ waits until gc is enabled in this thread." `(,(destructuring-bind (function &rest args) stream-dispatch `(,function stream ,@args))))) `(funcall (,slot stream) stream ,@args)))) + +(defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch) + `(with-out-stream/no-synonym ,stream (,slot ,@args) ,stream-dispatch)) + ;;;; These are hacks to make the reader win. diff --git a/version.lisp-expr b/version.lisp-expr index ec2c737..95ec3c3 100644 --- a/version.lisp-expr +++ b/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".) -"0.9.3.44" +"0.9.3.45" -- 1.7.10.4