\f
;;;; 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)))
(!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))
((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
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
single-float
bit-vector
long-float
- ;; MEMBER-TYPE #\a #\b ...
- ;; standard-char
+ standard-char
broadcast-stream
method
standard-class
string
condition
pathname
- ;; OR STRING-INPUT-STREAM STRING-OUTPUT-STREAM
- ;; FILL-POINTER-OUTPUT-STREAM
- ;; string-stream
+ string-stream
cons
print-not-readable
structure-class
;; 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
restart
unbound-slot
file-stream
- ;; (OR CONS NULL VECTOR)
- ;; sequence
+ sequence
unbound-variable
fixnum
serious-condition