From 0718147bfb76a6e1fae8f5567eda215d205bbacd Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 18 Sep 2002 12:14:20 +0000 Subject: [PATCH] 0.7.7.30: Fix analogous (to bug #195) unparse problems to the REAL -> (OR SINGLE-FLOAT DOUBLE-FLOAT RATIONAL) for all types defined by ANSI ... except EXTENDED-CHAR and ATOM, which are hard, so write comments about them instead. --- src/code/late-type.lisp | 14 +++++++++----- tests/type.pure.lisp | 21 +++++++++++++-------- version.lisp-expr | 2 +- 3 files changed, 23 insertions(+), 14 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index dd483f4..c61a3eb 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1008,8 +1008,9 @@ ;;;; hairy and unknown types -(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) - +(!define-type-method (hairy :unparse) (x) + (hairy-type-specifier x)) + (!define-type-method (hairy :simple-subtypep) (type1 type2) (let ((hairy-spec1 (hairy-type-specifier type1)) (hairy-spec2 (hairy-type-specifier type2))) @@ -2018,9 +2019,10 @@ (!define-type-method (member :unparse) (type) (let ((members (member-type-members type))) - (if (equal members '(nil)) - 'null - `(member ,@members)))) + (cond + ((equal members '(nil)) 'null) + ((type= type (specifier-type 'standard-char)) 'standard-char) + (t `(member ,@members))))) (!define-type-method (member :simple-subtypep) (type1 type2) (values (subsetp (member-type-members type1) (member-type-members type2)) @@ -2181,6 +2183,8 @@ ((type= type (specifier-type 'list)) 'list) ((type= type (specifier-type 'float)) 'float) ((type= type (specifier-type 'real)) 'real) + ((type= type (specifier-type 'sequence)) 'sequence) + ((type= type (specifier-type 'string-stream)) 'string-stream) (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 9222e6a..920a910 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -42,7 +42,15 @@ array generic-function simple-error - ;; (NOT CONS) + ;; so it might seem easy to change the HAIRY + ;; :UNPARSE method to recognize that (NOT + ;; CONS) should unparse as ATOM. However, we + ;; then lose the nice (SUBTYPEP '(NOT ATOM) + ;; 'CONS) => T,T behaviour that we get from + ;; simplifying (NOT ATOM) -> (NOT (NOT CONS)) + ;; -> CONS. So, for now, we leave this + ;; commented out. + ;; ;; atom hash-table simple-string @@ -60,8 +68,7 @@ single-float bit-vector long-float - ;; MEMBER-TYPE #\a #\b ... - ;; standard-char + standard-char broadcast-stream method standard-class @@ -88,9 +95,7 @@ string condition pathname - ;; OR STRING-INPUT-STREAM STRING-OUTPUT-STREAM - ;; FILL-POINTER-OUTPUT-STREAM - ;; string-stream + string-stream cons print-not-readable structure-class @@ -121,6 +126,7 @@ ;; obviously disjoint types and then do (the ;; extended-char foo), we'll get back FOO is ;; not a NIL. -- CSR, 2002-09-16. + ;; ;; extended-char real type-error @@ -128,8 +134,7 @@ restart unbound-slot file-stream - ;; (OR CONS NULL VECTOR) - ;; sequence + sequence unbound-variable fixnum serious-condition diff --git a/version.lisp-expr b/version.lisp-expr index 6d18da2..1ca0368 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; internal versions off the main CVS branch, it gets hairier, e.g. ;;; "0.pre7.14.flaky4.13".) -"0.7.7.29" +"0.7.7.30" -- 1.7.10.4