;;;; TYPEP und Verwandtes
;;;; Michael Stoll, 21. 10. 1988
;;;; Bruno Haible, 10.6.1989
;;;; Sam Steingold 2000-2005

;;; Datenstrukturen für TYPEP:
;;; - Ein Type-Specifier-Symbol hat auf seiner Propertyliste unter dem
;;;   Indikator SYS::TYPE-SYMBOL eine Funktion von einem Argument, die
;;;   testet, ob ein Objekt vom richtigen Typ ist.
;;; - Ein Symbol, das eine Type-Specifier-Liste beginnen kann, hat auf seiner
;;;   Propertyliste unter dem Indikator SYS::TYPE-LIST eine Funktion von
;;;   einem Argument für das zu testende Objekt und zusätzlichen Argumenten
;;;   für die Listenelemente.
;;; - Ein Symbol, das als Typmacro definiert wurde, hat auf seiner Property-
;;;   liste unter dem Indikator SYSTEM::DEFTYPE-EXPANDER den zugehörigen
;;;   Expander: eine Funktion, die den zu expandierenden Type-Specifier (eine
;;;   mindestens einelementige Liste) als Argument bekommt.

(in-package "EXT")
(export '(type-expand))
(in-package "SYSTEM")

; vorläufig, solange bis clos.lisp geladen wird:
(eval-when (eval)
  (predefun clos::built-in-class-p (object) (declare (ignore object)) nil))
(unless (fboundp 'clos::class-name)
  (defun clos::class-name (c) (declare (ignore c)) nil)
)

(defun typespec-error (fun type)
  (error-of-type 'error
    (TEXT "~S: invalid type specification ~S")
    fun type
) )

;; ============================================================================

;; return the CLOS class named by TYPESPEC or NIL
(defun clos-class (typespec)
  (let ((cc (get typespec 'CLOS::CLOSCLASS)))
    (when (and cc (clos::defined-class-p cc) (eq (clos:class-name cc) typespec))
      cc)))

;;; TYPEP, CLTL S. 72, S. 42-51
(defun typep (x y &optional env &aux f) ; x = Objekt, y = Typ
  (declare (ignore env))
  (setq y (expand-deftype y))
  (cond
    ((symbolp y)
       (cond ((setq f (get y 'TYPE-SYMBOL)) (funcall f x))
             ((setq f (get y 'TYPE-LIST)) (funcall f x))
             ((setq f (get y 'DEFSTRUCT-DESCRIPTION)) (ds-typep x y f))
             ((setq f (clos-class y))
              ; It's not worth handling structure classes specially here.
              (clos::typep-class x f))
             (t (typespec-error 'typep y))
    )  )
    ((and (consp y) (symbolp (first y)))
       (cond
         ((and (eq (first y) 'SATISFIES) (eql (length y) 2))
            (unless (symbolp (second y))
              (error-of-type 'error
                (TEXT "~S: argument to SATISFIES must be a symbol: ~S")
                'typep (second y)
            ) )
            (if (funcall (symbol-function (second y)) x) t nil)
         )
         ((eq (first y) 'MEMBER)
            (if (member x (rest y)) t nil)
         )
         ((and (eq (first y) 'EQL) (eql (length y) 2))
            (eql x (second y))
         )
         ((and (eq (first y) 'NOT) (eql (length y) 2))
            (not (typep x (second y)))
         )
         ((eq (first y) 'AND)
            (dolist (type (rest y) t)
              (unless (typep x type) (return nil))
         )  )
         ((eq (first y) 'OR)
            (dolist (type (rest y) nil)
              (when (typep x type) (return t))
         )  )
         ((setq f (get (first y) 'TYPE-LIST)) (apply f x (rest y)))
         (t (typespec-error 'typep y))
    )  )
    ((clos::defined-class-p y) (clos::typep-class x y))
    ((clos::eql-specializer-p y) (eql x (clos::eql-specializer-singleton y)))
    ((encodingp y) (charset-typep x y))
    (t (typespec-error 'typep y))
) )

;; ----------------------------------------------------------------------------

;; UPGRADED-ARRAY-ELEMENT-TYPE is a lattice homomorphism, see
;; ANSI CL 15.1.2.1.
(defun upgraded-array-element-type (type &optional environment)
  (declare (ignore environment))
  ;; see array.d
  (case type
    ((BIT) 'BIT)
    ((CHARACTER) 'CHARACTER)
    ((T) 'T)
    ((NIL) 'NIL)
    (t (if (subtypep type 'NIL)
         'NIL
         (multiple-value-bind (low high) (sys::subtype-integer type)
           ; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high)))
           (if (and (integerp low) (not (minusp low)) (integerp high))
             (let ((l (integer-length high)))
               ; Es gilt (subtypep type `(UNSIGNED-BYTE ,l))
               (cond ((<= l 1) 'BIT)
                     ((<= l 2) '(UNSIGNED-BYTE 2))
                     ((<= l 4) '(UNSIGNED-BYTE 4))
                     ((<= l 8) '(UNSIGNED-BYTE 8))
                     ((<= l 16) '(UNSIGNED-BYTE 16))
                     ((<= l 32) '(UNSIGNED-BYTE 32))
                     (t 'T)))
             (if (subtypep type 'CHARACTER)
               'CHARACTER
               'T)))))))

;; ----------------------------------------------------------------------------

;; UPGRADED-COMPLEX-PART-TYPE is a lattice homomorphism, see
;; HyperSpec/Body/fun_complex.html and HyperSpec/Body/syscla_complex.html,
;; and an idempotent. Therefore
;;   (subtypep (upgraded-complex-part-type T1) (upgraded-complex-part-type T2))
;; is equivalent to
;;   (subtypep T1 (upgraded-complex-part-type T2))
;; (Proof: Let U T be an abbreviation for (upgraded-complex-part-type T).
;;  If U T1 <= U T2, then T1 <= U T1 <= U T2.
;;  If T1 <= U T2, then by homomorphism U T1 <= U U T2 = U T2.)
;;
;; For _any_ CL implementation, you could define
;;   (defun upgraded-complex-part-type (type) 'REAL)
;; Likewise for _any_ CL implementation, you could define
;;   (defun upgraded-complex-part-type (type) type)
;; or - again for _any_ CL implementation:
;;   (defun upgraded-complex-part-type (type)
;;     (cond ((subtypep type 'NIL) 'NIL)
;;           ((subtypep type 'SHORT-FLOAT) 'SHORT-FLOAT)
;;           ((subtypep type 'SINGLE-FLOAT) 'SINGLE-FLOAT)
;;           ((subtypep type 'DOUBLE-FLOAT) 'DOUBLE-FLOAT)
;;           ((subtypep type 'LONG-FLOAT) 'LONG-FLOAT)
;;           ((subtypep type 'RATIONAL) 'RATIONAL)
;;           ((subtypep type 'REAL) 'REAL)
;;           (t (error ...))))
;; The reason is that a complex number is immutable: no setters for the
;; realpart and imagpart exist.
;;
;; We choose the second implementation because it allows the most precise
;; type inference.
(defun upgraded-complex-part-type (type &optional environment)
  (declare (ignore environment))
  (if (subtypep type 'REAL)
    type
    (error-of-type 'error
      (TEXT "~S: type ~S is not a subtype of ~S")
      'upgraded-complex-part-type type 'real)))

;; ----------------------------------------------------------------------------

;; Macros for defining the various built-in "atomic type specifier"s and
;; "compound type specifier"s. The following macros add information for both
;; the TYPEP function above and the c-TYPEP in the compiler.

; Alist symbol -> funname, used by the compiler.
(defparameter c-typep-alist1 '())
; Alist symbol -> lambdabody, used by the compiler.
(defparameter c-typep-alist2 '())
; Alist symbol -> expander function, used by the compiler.
(defparameter c-typep-alist3 '())

; (def-atomic-type symbol function-name)
; defines an atomic type. The function-name designates a function taking one
; argument and returning a generalized boolean value. It can be either a
; symbol or a lambda expression.
(defmacro def-atomic-type (symbol funname)
  (let ((lambdap (and (consp funname) (eq (car funname) 'LAMBDA))))
    `(PROGN
       (SETF (GET ',symbol 'TYPE-SYMBOL)
             ,(if lambdap
                `(FUNCTION ,(concat-pnames "TYPE-SYMBOL-" symbol) ,funname)
                `(FUNCTION ,funname)
              )
       )
       ,(if lambdap
          `(SETQ C-TYPEP-ALIST2
                 (NCONC C-TYPEP-ALIST2 (LIST (CONS ',symbol ',(cdr funname))))
           )
          `(SETQ C-TYPEP-ALIST1
                 (NCONC C-TYPEP-ALIST1 (LIST (CONS ',symbol ',funname)))
           )
        )
       ',symbol
     )
) )

; (def-compound-type symbol lambda-list (x) check-form typep-form c-typep-form)
; defines a compound type. The lambda-list is of the form (&optional ...)
; where the arguments come from the CDR of the type specifier.
; For typep-form, x is an object.
; For c-typep-form, x is a multiply evaluatable form (actually a gensym).
; check-form is a form performing error checking, may call `error'.
; typep-form should return a generalized boolean value.
; c-typep-form should produce a form returning a generalized boolean value.
(defmacro def-compound-type (symbol lambdalist (var) check-form typep-form c-typep-form)
  `(PROGN
     (SETF (GET ',symbol 'TYPE-LIST)
           (FUNCTION ,(concat-pnames "TYPE-LIST-" symbol)
             (LAMBDA (,var ,@lambdalist)
               ,@(if check-form
                   `((MACROLET ((ERROR (&REST ERROR-ARGS)
                                  (LIST* 'ERROR-OF-TYPE ''ERROR ERROR-ARGS)
                               ))
                       ,check-form
                    ))
                 )
               ,typep-form
     )     ) )
     (SETQ C-TYPEP-ALIST3
           (NCONC C-TYPEP-ALIST3
                  (LIST (CONS ',symbol
                              #'(LAMBDA (,var ,@lambdalist &REST ILLEGAL-ARGS)
                                  (DECLARE (IGNORE ILLEGAL-ARGS))
                                  ,@(if check-form
                                      `((MACROLET ((ERROR (&REST ERROR-ARGS)
                                                     (LIST 'PROGN
                                                           (LIST* 'C-WARN ERROR-ARGS)
                                                           '(THROW 'C-TYPEP NIL)
                                                  )) )
                                          ,check-form
                                       ))
                                    )
                                  ,c-typep-form
                                )
     )     )      )     )
     ',symbol
   )
)

; CLtL1 p. 43
(def-atomic-type ARRAY arrayp)
(def-atomic-type ATOM atom)
(def-atomic-type BASE-CHAR
  #+BASE-CHAR=CHARACTER
  characterp
  #-BASE-CHAR=CHARACTER
  (lambda (x) (and (characterp x) (base-char-p x)))
)
(def-atomic-type BASE-STRING
  (lambda (x)
    (and (stringp x)
         (eq (array-element-type x)
             #+BASE-CHAR=CHARACTER 'CHARACTER #-BASE-CHAR=CHARACTER 'BASE-CHAR
) ) )    )
(def-atomic-type BIGNUM
  (lambda (x) (and (integerp x) (not (fixnump x))))
)
(def-atomic-type BIT
  (lambda (x) (or (eql x 0) (eql x 1)))
)
(def-atomic-type BIT-VECTOR bit-vector-p)
(def-atomic-type BOOLEAN
  (lambda (x) (or (eq x 'nil) (eq x 't)))
)
(def-atomic-type CHARACTER characterp)
(def-atomic-type COMPILED-FUNCTION compiled-function-p)
(def-atomic-type COMPLEX complexp)
(def-atomic-type CONS consp)
(def-atomic-type DOUBLE-FLOAT double-float-p)
(def-atomic-type ENCODING encodingp)
(def-atomic-type EXTENDED-CHAR
  #+BASE-CHAR=CHARACTER
  (lambda (x) (declare (ignore x)) nil)
  #-BASE-CHAR=CHARACTER
  (lambda (x) (and (characterp x) (not (base-char-p x))))
)
(def-atomic-type FIXNUM fixnump)
(def-atomic-type FLOAT floatp)
(def-atomic-type FUNCTION functionp)
(def-atomic-type HASH-TABLE hash-table-p)
(def-atomic-type INTEGER integerp)
(def-atomic-type KEYWORD keywordp)
(def-atomic-type LIST listp)
#+LOGICAL-PATHNAMES
(def-atomic-type LOGICAL-PATHNAME logical-pathname-p)
(def-atomic-type LONG-FLOAT long-float-p)
(def-atomic-type NIL
  (lambda (x) (declare (ignore x)) nil)
)
(def-atomic-type NULL null)
(def-atomic-type NUMBER numberp)
(def-atomic-type PACKAGE packagep)
(def-atomic-type PATHNAME pathnamep)
(def-atomic-type RANDOM-STATE random-state-p)
(def-atomic-type RATIO
  (lambda (x) (and (rationalp x) (not (integerp x))))
)
(def-atomic-type RATIONAL rationalp)
(def-atomic-type READTABLE readtablep)
(def-atomic-type REAL realp)
(def-atomic-type SEQUENCE sequencep)
(def-atomic-type SHORT-FLOAT short-float-p)
(def-atomic-type SIMPLE-ARRAY simple-array-p)
(def-atomic-type SIMPLE-BASE-STRING
  (lambda (x)
    (and (simple-string-p x)
         (eq (array-element-type x)
             #+BASE-CHAR=CHARACTER 'CHARACTER #-BASE-CHAR=CHARACTER 'BASE-CHAR
) ) )    )
(def-atomic-type SIMPLE-BIT-VECTOR simple-bit-vector-p)
(def-atomic-type SIMPLE-STRING simple-string-p)
(def-atomic-type SIMPLE-VECTOR simple-vector-p)
(def-atomic-type SINGLE-FLOAT single-float-p)
(defun %standard-char-p (x) (and (characterp x) (standard-char-p x))) ; ABI
(def-atomic-type STANDARD-CHAR %standard-char-p)
(def-atomic-type CLOS:STANDARD-OBJECT clos::std-instance-p)
(def-atomic-type STREAM streamp)
(def-atomic-type FILE-STREAM file-stream-p)
(def-atomic-type SYNONYM-STREAM synonym-stream-p)
(def-atomic-type BROADCAST-STREAM broadcast-stream-p)
(def-atomic-type CONCATENATED-STREAM concatenated-stream-p)
(def-atomic-type TWO-WAY-STREAM two-way-stream-p)
(def-atomic-type ECHO-STREAM echo-stream-p)
(def-atomic-type STRING-STREAM string-stream-p)
(def-atomic-type STRING stringp)
(def-atomic-type STRING-CHAR characterp)
(def-atomic-type CLOS:STRUCTURE-OBJECT clos::structure-object-p)
(def-atomic-type SYMBOL symbolp)
(def-atomic-type T (lambda (x) (declare (ignore x)) t))
;; foreign1.lisp is loaded after this file,
;; so these symbols are not external yet
#+ffi
(def-atomic-type ffi::foreign-function
  (lambda (x) (eq 'ffi::foreign-function (type-of x))))
#+ffi
(def-atomic-type ffi::foreign-variable
  (lambda (x) (eq 'ffi::foreign-variable (type-of x))))
#+ffi
(def-atomic-type ffi::foreign-address
  (lambda (x) (eq 'ffi::foreign-address (type-of x))))
;; see lispbibl.d (#define FOREIGN) and predtype.d (TYPE-OF):
#+(or unix ffi affi win32)
(def-atomic-type foreign-pointer
  (lambda (x) (eq 'foreign-pointer (type-of x))))
(def-atomic-type VECTOR vectorp)
(def-atomic-type PLIST
    (lambda (x) (multiple-value-bind (length tail) (list-length-dotted x)
                  (and (null tail) (evenp length)))))

(defmacro ensure-dim (type dim)
  ;; make sure DIM is a valid dimension
  `(unless (or (eq ,dim '*) (typep ,dim `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))))
     (error (TEXT "~S: dimension ~S is invalid") ',type ,dim)))

(defmacro ensure-rank (type rank)
  ;; make sure RANK is a valid rank
  `(unless (typep ,rank `(INTEGER 0 (,ARRAY-RANK-LIMIT)))
     (error (TEXT "~S: rank ~S is invalid") ',type ,rank)))

; CLtL1 p. 46-50
(defun c-typep-array (tester el-type dims x)
  `(AND (,tester ,x)
        ,@(if (eq el-type '*)
            '()
            `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
          )
        ,@(if (eq dims '*)
            '()
            (if (numberp dims)
              `((EQL ,dims (ARRAY-RANK ,x)))
              `((EQL ,(length dims) (ARRAY-RANK ,x))
                ,@(let ((i 0))
                    (mapcap #'(lambda (dim)
                                (prog1
                                  (if (eq dim '*)
                                    '()
                                    `((EQL ',dim (ARRAY-DIMENSION ,x ,i)))
                                  )
                                  (incf i)
                              ) )
                            dims
                  ) )
               )
          ) )
   )
)
(defun c-typep-vector (tester size x)
  `(AND (,tester ,x)
        ,@(if (eq size '*)
            '()
            `((EQL ',size (ARRAY-DIMENSION ,x 0)))
          )
   )
)
(defun typep-number-test (x low high test type)
  (and (funcall test x)
       (cond ((eq low '*))
             ((funcall test low) (<= low x))
             ((and (consp low) (null (rest low)) (funcall test (first low)))
                (< (first low) x)
             )
             (t (error-of-type 'error
                  #1=(TEXT "~S: argument to ~S must be *, ~S or a list of ~S: ~S")
                  'typep type type type low
       )     )  )
       (cond ((eq high '*))
             ((funcall test high) (>= high x))
             ((and (consp high) (null (rest high)) (funcall test (first high)))
                (> (first high) x)
             )
             (t (error-of-type 'error
                  #1# 'typep type type type high
) )    )     )  )
(defun c-typep-number (caller tester low high x)
  `(AND (,tester ,x)
        ,@(cond ((eq low '*) '())
                ((funcall tester low) `((<= ,low ,x)))
                ((and (consp low) (null (rest low)) (funcall tester (first low)))
                 `((< ,(first low) ,x))
                )
                (t (c-warn #1=(TEXT "~S: argument to ~S must be *, ~S or a list of ~S: ~S")
                           'typep caller caller caller low
                   )
                   (throw 'c-TYPEP nil)
          )     )
        ,@(cond ((eq high '*) '())
                ((funcall tester high) `((>= ,high ,x)))
                ((and (consp high) (null (rest high)) (funcall tester (first high)))
                 `((> ,(first high) ,x))
                )
                (t (c-warn #1# 'typep caller caller caller high)
                   (throw 'c-TYPEP nil)
          )     )
   )
)
(def-compound-type ARRAY (&optional (el-type '*) (dims '*)) (x)
  (unless (eq dims '*)
    (if (numberp dims)
      (ensure-rank ARRAY dims)
      (dolist (dim dims) (ensure-dim ARRAY dim))))
  (and (arrayp x)
       (or (eq el-type '*)
           (equal (array-element-type x) (upgraded-array-element-type el-type))
       )
       (or (eq dims '*)
           (if (numberp dims)
             (eql dims (array-rank x))
             (and (eql (length dims) (array-rank x))
                  (every #'(lambda (a b) (or (eq a '*) (eql a b)))
                         dims (array-dimensions x)
  )    )   ) )    )
  (c-typep-array 'ARRAYP el-type dims x)
)
(def-compound-type SIMPLE-ARRAY (&optional (el-type '*) (dims '*)) (x)
  (unless (eq dims '*)
    (if (numberp dims)
      (ensure-rank SIMPLE-ARRAY dims)
      (dolist (dim dims) (ensure-dim SIMPLE-ARRAY dim))))
  (and (simple-array-p x)
       (or (eq el-type '*)
           (equal (array-element-type x) (upgraded-array-element-type el-type))
       )
       (or (eq dims '*)
           (if (numberp dims)
             (eql dims (array-rank x))
             (and (eql (length dims) (array-rank x))
                  (every #'(lambda (a b) (or (eq a '*) (eql a b)))
                         dims (array-dimensions x)
  )    )   ) )    )
  (c-typep-array 'SIMPLE-ARRAY-P el-type dims x)
)
(def-compound-type VECTOR (&optional (el-type '*) (size '*)) (x)
  (ensure-dim VECTOR size)
  (and (vectorp x)
       (or (eq el-type '*)
           (equal (array-element-type x) (upgraded-array-element-type el-type))
       )
       (or (eq size '*) (eql (array-dimension x 0) size))
  )
  `(AND (VECTORP ,x)
        ,@(if (eq el-type '*)
            '()
            `((EQUAL (ARRAY-ELEMENT-TYPE ,x) ',(upgraded-array-element-type el-type)))
          )
        ,@(if (eq size '*)
            '()
            `((EQL (ARRAY-DIMENSION ,x 0) ',size))
          )
   )
)
(def-compound-type SIMPLE-VECTOR (&optional (size '*)) (x)
  (ensure-dim SIMLPE-VECTOR size)
  (and (simple-vector-p x)
       (or (eq size '*) (eql size (array-dimension x 0)))
  )
  (c-typep-vector 'SIMPLE-VECTOR-P size x)
)
(def-compound-type COMPLEX (&optional (rtype '*) (itype rtype)) (x)
  nil
  (and (complexp x)
       (or (eq rtype '*)
           (typep (realpart x) (upgraded-complex-part-type rtype)))
       (or (eq itype '*)
           (typep (imagpart x) (upgraded-complex-part-type itype))))
  `(AND (COMPLEXP ,x)
        ,@(if (eq rtype '*)
            '()
            `((TYPEP (REALPART ,x) ',(upgraded-complex-part-type rtype))))
        ,@(if (eq itype '*)
            '()
            `((TYPEP (IMAGPART ,x) ',(upgraded-complex-part-type itype))))))
(def-compound-type INTEGER (&optional (low '*) (high '*)) (x)
  nil
  (typep-number-test x low high #'integerp 'INTEGER)
  (c-typep-number 'INTEGER 'INTEGERP low high x)
)
(def-compound-type MOD (n) (x)
  (unless (integerp n)
    (error (TEXT "~S: argument to MOD must be an integer: ~S")
           'typep n
  ) )
  (and (integerp x) (<= 0 x) (< x n))
  `(AND (INTEGERP ,x) (NOT (MINUSP ,x)) (< ,x ,n))
)
(def-compound-type SIGNED-BYTE (&optional (n '*)) (x)
  (unless (or (eq n '*) (integerp n))
    (error (TEXT "~S: argument to SIGNED-BYTE must be an integer or * : ~S")
           'typep n
  ) )
  (and (integerp x) (or (eq n '*) (< (integer-length x) n)))
  `(AND (INTEGERP ,x)
        ,@(if (eq n '*) '() `((< (INTEGER-LENGTH ,x) ,n)))
   )
)
(def-compound-type UNSIGNED-BYTE (&optional (n '*)) (x)
  (unless (or (eq n '*) (integerp n))
    (error (TEXT "~S: argument to UNSIGNED-BYTE must be an integer or * : ~S")
           'typep n
  ) )
  (and (integerp x)
       (not (minusp x))
       (or (eq n '*) (<= (integer-length x) n))
  )
  `(AND (INTEGERP ,x) (NOT (MINUSP ,x))
        ,@(if (eq n '*) '() `((<= (INTEGER-LENGTH ,x) ,n)))
   )
)
(def-compound-type REAL (&optional (low '*) (high '*)) (x)
  nil
  (typep-number-test x low high #'realp 'REAL)
  (c-typep-number 'REAL 'REALP low high x)
)
(def-compound-type RATIONAL (&optional (low '*) (high '*)) (x)
  nil
  (typep-number-test x low high #'rationalp 'RATIONAL)
  (c-typep-number 'RATIONAL 'RATIONALP low high x)
)
(def-compound-type FLOAT (&optional (low '*) (high '*)) (x)
  nil
  (typep-number-test x low high #'floatp 'FLOAT)
  (c-typep-number 'FLOAT 'FLOATP low high x)
)
(def-compound-type SHORT-FLOAT (&optional (low '*) (high '*)) (x)
  nil
  (typep-number-test x low high #'short-float-p 'SHORT-FLOAT)
  (c-typep-number 'SHORT-FLOAT 'SHORT-FLOAT-P low high x)
)
(def-compound-type SINGLE-FLOAT (&optional (low '*) (high '*)) (x)
  nil
  (typep-number-test x low high #'single-float-p 'SINGLE-FLOAT)
  (c-typep-number 'SINGLE-FLOAT 'SINGLE-FLOAT-P low high x)
)
(def-compound-type DOUBLE-FLOAT (&optional (low '*) (high '*)) (x)
  nil
  (typep-number-test x low high #'double-float-p 'DOUBLE-FLOAT)
  (c-typep-number 'DOUBLE-FLOAT 'DOUBLE-FLOAT-P low high x)
)
(def-compound-type LONG-FLOAT (&optional (low '*) (high '*)) (x)
  nil
  (typep-number-test x low high #'long-float-p 'LONG-FLOAT)
  (c-typep-number 'LONG-FLOAT 'LONG-FLOAT-P low high x)
)
(def-compound-type STRING (&optional (size '*)) (x)
  (ensure-dim STRING size)
  (and (stringp x)
       (or (eq size '*) (eql size (array-dimension x 0)))
  )
  (c-typep-vector 'STRINGP size x)
)
(def-compound-type SIMPLE-STRING (&optional (size '*)) (x)
  (ensure-dim SIMPLE-STRING size)
  (and (simple-string-p x)
       (or (eq size '*) (eql size (array-dimension x 0)))
  )
  (c-typep-vector 'SIMPLE-STRING-P size x)
)
(def-compound-type BASE-STRING (&optional (size '*)) (x)
  (ensure-dim BASE-STRING size)
  (and (stringp x)
       (or (eq size '*) (eql size (array-dimension x 0)))
  )
  (c-typep-vector 'STRINGP size x)
)
(def-compound-type SIMPLE-BASE-STRING (&optional (size '*)) (x)
  (ensure-dim SIMPLE-BASE-STRING size)
  (and (simple-string-p x)
       (or (eq size '*) (eql size (array-dimension x 0)))
  )
  (c-typep-vector 'SIMPLE-STRING-P size x)
)
(def-compound-type BIT-VECTOR (&optional (size '*)) (x)
  (ensure-dim BIT-VECTOR size)
  (and (bit-vector-p x)
       (or (eq size '*) (eql size (array-dimension x 0)))
  )
  (c-typep-vector 'BIT-VECTOR-P size x)
)
(def-compound-type SIMPLE-BIT-VECTOR (&optional (size '*)) (x)
  (ensure-dim SIMPLE-BIT-VECTOR size)
  (and (simple-bit-vector-p x)
       (or (eq size '*) (eql size (array-dimension x 0)))
  )
  (c-typep-vector 'SIMPLE-BIT-VECTOR-P size x)
)
(def-compound-type CONS (&optional (car-type '*) (cdr-type '*)) (x)
  nil
  (and (consp x)
       (or (eq car-type '*) (typep (car x) car-type))
       (or (eq cdr-type '*) (typep (cdr x) cdr-type))
  )
  `(AND (CONSP ,x)
        ,@(if (eq car-type '*) '() `((TYPEP (CAR ,x) ',car-type)))
        ,@(if (eq cdr-type '*) '() `((TYPEP (CDR ,x) ',cdr-type)))
   )
)

(fmakunbound 'def-compound-type)

;; ----------------------------------------------------------------------------

; Typtest ohne Gefahr einer Fehlermeldung. Für SIGNAL und HANDLER-BIND.
(defun safe-typep (x y &optional env)
  (let ((*error-handler*
          #'(lambda (&rest error-args)
              (declare (ignore error-args))
              (return-from safe-typep (values nil nil))
       ))   )
    (values (typep x y env) t)
) )

; Umwandlung eines "type for declaration" in einen "type for discrimination".
(defun type-for-discrimination (y &optional (notp nil) &aux f)
  (cond ((symbolp y)
           (cond ((get y 'TYPE-SYMBOL) y)
                 ((get y 'TYPE-LIST) y)
                 ((setq f (get y 'DEFTYPE-EXPANDER))
                  (let* ((z (funcall f (list y)))
                         (zx (type-for-discrimination z notp)))
                    (if (eql zx z) y zx)
                 ))
                 (t y)
        )  )
        ((and (consp y) (symbolp (first y)))
           (case (first y)
             ((SATISFIES MEMBER EQL) y)
             (NOT
              (let* ((z (second y))
                     (zx (type-for-discrimination z (not notp))))
                (if (eql zx z) y `(NOT ,zx))
             ))
             ((AND OR COMPLEX VALUES)
              (let* ((z (rest y))
                     (zx (mapcar #'(lambda (x) (type-for-discrimination x notp)) z)))
                (if (every #'eql z zx) y (cons (first y) zx))
             ))
             (FUNCTION
              ;; (FUNCTION arg-types res-type) is somewhere between
              ;; NIL and FUNCTION, but undecidable.
              (if notp 'NIL 'FUNCTION)
             )
             (t (cond ((get (first y) 'TYPE-LIST) y)
                      ((setq f (get (first y) 'DEFTYPE-EXPANDER))
                       (let* ((z (funcall f y))
                              (zx (type-for-discrimination z notp)))
                         (if (eql zx z) y zx)
                      ))
                      (t y)
        )  ) )  )
        (t y)
) )

; Testet eine Liste von Werten auf Erfüllen eines Type-Specifiers. Für THE.
(defun %the (values type) ; ABI
  (macrolet ((near-typep (objform typform)
               ;; near-typep ist wie typep, nur dass das Objekt auch ein
               ;; Read-Label sein darf. Das tritt z.B. auf bei
               ;; (read-from-string "#1=#S(FOO :X #1#)")
               ;; im Konstruktor MAKE-FOO. Die Implementation ist aber
               ;; nicht gezwungen, bei fehlerhaftem THE zwingend einen
               ;; Fehler zu melden, darum ist ein lascherer Typcheck hier
               ;; erlaubt.
               (let ((g (gensym)))
                 `(let ((,g ,objform))
                    (or (typep ,g ,typform) (eq (type-of ,g) 'READ-LABEL))))))
    (if (and (consp type) (eq (car type) 'VALUES))
      ;; The VALUES type specifier is ill-defined in ANSI CL.
      ;;
      ;; There are two possibilities to define a VALUES type specifier in a
      ;; sane way:
      ;; - (EXACT-VALUES type1 ... [&optional ...]) describes the exact shape
      ;;   of the values list, as received by MULTIPLE-VALUE-LIST.
      ;;   For example, (EXACT-VALUES SYMBOL) is matched by (values 'a) but not
      ;;   by (values 'a 'b) or (values).
      ;; - (ASSIGNABLE-VALUES type1 ... [&optional ...]) describes the values
      ;;   as received by a set of variables through MULTIPLE-VALUE-BIND or
      ;;   MULTIPLE-VALUE-SETQ. For example, (ASSIGNABLE-VALUES SYMBOL) is
      ;;   defined by whether
      ;;     (MULTIPLE-VALUE-BIND (var1) values (DECLARE (TYPE SYMBOL var1)) ...)
      ;;   is valid or not; therefore (ASSIGNABLE-VALUES SYMBOL) is matched by
      ;;   (values 'a) and (values 'a 'b) and (values).
      ;;   Note that &OPTIONAL is actually redundant here:
      ;;     (ASSIGNABLE-VALUES type1 ... &optional otype1 ...)
      ;;   is equivalent to
      ;;     (ASSIGNABLE-VALUES type1 ... (OR NULL otype1) ...)
      ;; HyperSpec/Body/typspe_values.html indicates that VALUES means
      ;; EXACT-VALUES; however, HyperSpec/Body/speope_the.html indicates that
      ;; VALUES means ASSIGNABLE-VALUES.
      ;;
      ;; SBCL interprets the VALUES type specifier to mean EXACT-VALUES when
      ;; it contains &OPTIONAL or &REST, but ASSIGNABLE-VALUES when it has
      ;; only a tuple of type specifiers. This is utter nonsense, in particular
      ;; because it makes (VALUES type1 ... typek &OPTIONAL)
      ;; different from   (VALUES type1 ... typek).
      ;;
      ;; Here we use the ASSIGNABLE-VALUES interpretation.
      ;; In SUBTYPEP we just punt and don't assume any interpretation.
      (let ((vals values) (types (cdr type)))
        ;; required:
        (loop
          (when (or (atom types) (atom vals)) (return-from %the t))
          (when (memq (car types) lambda-list-keywords) (return))
          (unless (near-typep (pop vals) (pop types))
            (return-from %the nil)))
        ;; &optional:
        (when (and (consp types) (eq (car types) '&optional))
          (setq types (cdr types))
          (loop
            (when (or (atom types) (atom vals)) (return-from %the t))
            (when (memq (car types) lambda-list-keywords) (return))
            (unless (near-typep (pop vals) (pop types))
              (return-from %the nil))))
        ;; &rest &key:
        (case (car types)
          (&rest
           (setq types (cdr types))
           (when (atom types) (typespec-error 'the type))
           (unless (near-typep (pop vals) (pop types))
             (return-from %the nil)))
          (&key)
          (t (typespec-error 'the type)))
        (if (eq (car types) '&key)
          (progn
            (setq types (cdr types))
            (when (oddp (length vals)) (return-from %the nil))
            (let ((keywords nil))
              (loop
                (when (or (atom types) (atom vals)) (return-from %the t))
                (when (memq (car types) lambda-list-keywords) (return))
                (let ((item (pop types)))
                  (unless (and (listp item) (eql (length item) 2)
                               (symbolp (first item)))
                    (typespec-error 'the type))
                  (let ((kw (symbol-to-keyword (first item))))
                    (unless (near-typep (getf vals kw) (second item))
                      (return-from %the nil))
                    (push kw keywords))))
              (if (and (consp types) (eq (car types) '&allow-other-keys))
                (setq types (cdr types))
                (unless (getf vals ':allow-other-keys)
                  (do ((L vals (cddr L)))
                      ((atom L))
                    (unless (memq (car L) keywords)
                      (return-from %the nil)))))))
          (when (consp types) (typespec-error 'the type)))
        t)
      (near-typep (if (consp values) (car values) nil) type))))

;;; ===========================================================================

;; SUBTYPEP
(load "subtypep")


;; Returns the number of bytes that are needed to represent #\Null in a
;; given encoding.
(defun encoding-zeroes (encoding)
  #+UNICODE
  ;; this should use min_bytes_per_char for cache, not the hash table
  (let ((name (ext:encoding-charset encoding))
        (table #.(make-hash-table :key-type '(or string symbol) :value-type 'fixnum
                                  :test 'stablehash-equal :warn-if-needs-rehash-after-gc t
                                  :initial-contents '(("UTF-7" . 1))))
        (tester #.(make-string 2 :initial-element (code-char 0))))
    (or (gethash name table)
        (setf (gethash name table)
              (- (length (ext:convert-string-to-bytes tester encoding))
                 (length (ext:convert-string-to-bytes tester encoding
                                                      :end 1))))))
  #-UNICODE 1)

;; Determines two values low,high such that
;;   (subtypep type `(INTEGER ,low ,high))
;; holds and low is as large as possible and high is as small as possible.
;; low = * means -infinity, high = * means infinity.
;; When (subtypep type 'INTEGER) is false, the values NIL,NIL are returned.
;; We need this function only for MAKE-ARRAY, UPGRADED-ARRAY-ELEMENT-TYPE and
;; OPEN and can therefore w.l.o.g. replace
;;   type  with  `(OR ,type (MEMBER 0))
#| ;; The original implementation calls canonicalize-type and then applies
   ;; a particular SUBTYPE variant:
 (defun subtype-integer (type)
  (macrolet ((yes () '(return-from subtype-integer (values low high)))
             (no () '(return-from subtype-integer nil))
             (unknown () '(return-from subtype-integer nil)))
    (setq type (canonicalize-type type))
    (if (consp type)
      (case (first type)
        (MEMBER ; (MEMBER &rest objects)
          ;; All elements must be of type INTEGER.
          (let ((low 0) (high 0)) ; wlog!
            (dolist (x (rest type) (yes))
              (unless (typep x 'INTEGER) (return (no)))
              (setq low (min low x) high (max high x)))))
        (OR ; (OR type*)
          ;; Every type must be subtype of INTEGER.
          (let ((low 0) (high 0)) ; wlog!
            (dolist (type1 (rest type) (yes))
              (multiple-value-bind (low1 high1) (subtype-integer type1)
                (unless low1 (return (no)))
                (setq low (if (or (eq low '*) (eq low1 '*)) '* (min low low1))
                      high (if (or (eq high '*) (eq high1 '*))
                               '* (max high high1)))))))
        (AND ; (AND type*)
          ;; If one of the types is subtype of INTEGER, then yes,
          ;; otherwise unknown.
          (let ((low nil) (high nil))
            (dolist (type1 (rest type))
              (multiple-value-bind (low1 high1) (subtype-integer type1)
                (when low1
                  (if low
                    (setq low (if (eq low '*) low1 (if (eq low1 '*) low (max low low1)))
                          high (if (eq high '*) high1 (if (eq high1 '*) high (min high high1))))
                    (setq low low1 high high1)))))
            (if low
              (progn
                (when (and (numberp low) (numberp high) (not (<= low high)))
                  (setq low 0 high 0) ; type equivalent to NIL)
                (yes))
              (unknown)))))
      (setq type (list type)))
    (if (eq (first type) 'INTEGER)
      (let ((low (if (rest type) (second type) '*))
            (high (if (cddr type) (third type) '*)))
        (when (consp low)
          (setq low (first low))
          (when (numberp low) (incf low)))
        (when (consp high)
          (setq high (first high))
          (when (numberp high) (decf high)))
        (when (and (numberp low) (numberp high) (not (<= low high))) ; type leer?
          (setq low 0 high 0))
        (yes))
      (if (and (eq (first type) 'INTERVALS) (eq (second type) 'INTEGER))
        (let ((low (third type))
              (high (car (last type))))
          (when (consp low)
            (setq low (first low))
            (when (numberp low) (incf low)))
          (when (consp high)
            (setq high (first high))
            (when (numberp high) (decf high)))
          (yes))
        (unknown)))))
|# ;; This implementation inlines the (tail-recursive) canonicalize-type
   ;; function. Its advantage is that it doesn't cons as much.
   ;; (For example, (subtype-integer '(UNSIGNED-BYTE 8)) doesn't cons.)
(defun subtype-integer (type)
  (macrolet ((yes () '(return-from subtype-integer (values low high)))
             (no () '(return-from subtype-integer nil))
             (unknown () '(return-from subtype-integer nil)))
    (setq type (expand-deftype type))
    (cond ((symbolp type)
           (case type
             (BIT (let ((low 0) (high 1)) (yes)))
             (FIXNUM
              (let ((low '#,most-negative-fixnum)
                    (high '#,most-positive-fixnum))
                (yes)))
             ((INTEGER BIGNUM SIGNED-BYTE)
              (let ((low '*) (high '*)) (yes)))
             (UNSIGNED-BYTE
              (let ((low 0) (high '*)) (yes)))
             ((NIL)
              (let ((low 0) (high 0)) (yes))) ; wlog!
             (t (no))))
          ((and (consp type) (symbolp (first type)))
           (unless (and (list-length type) (null (cdr (last type))))
             (typespec-error 'subtypep type))
           (case (first type)
             (MEMBER ; (MEMBER &rest objects)
              ;; All elements must be of type INTEGER.
              (let ((low 0) (high 0)) ; wlog!
                (dolist (x (rest type) (yes))
                  (unless (typep x 'INTEGER) (return (no)))
                  (setq low (min low x) high (max high x)))))
             (EQL ; (EQL object)
              (let ((x (second type)))
                (if (typep x 'INTEGER)
                  (let ((low (min 0 x)) (high (max 0 x))) (yes))
                  (no))))
             (OR ; (OR type*)
              ;; Every type must be subtype of INTEGER.
              (let ((low 0) (high 0)) ; wlog!
                (dolist (type1 (rest type) (yes))
                  (multiple-value-bind (low1 high1) (subtype-integer type1)
                    (unless low1 (return (no)))
                    (setq low (if (or (eq low '*) (eq low1 '*))
                                  '* (min low low1))
                          high (if (or (eq high '*) (eq high1 '*))
                                   '* (max high high1)))))))
             (AND ; (AND type*)
              ;; If one of the types is subtype of INTEGER, then yes,
              ;; otherwise unknown.
              (let ((low nil) (high nil))
                (dolist (type1 (rest type))
                  (multiple-value-bind (low1 high1) (subtype-integer type1)
                    (when low1
                      (if low
                        (setq low (if (eq low '*) low1
                                      (if (eq low1 '*) low
                                          (max low low1)))
                              high (if (eq high '*) high1
                                       (if (eq high1 '*) high
                                           (min high high1))))
                        (setq low low1
                              high high1)))))
                (if low
                  (progn
                    (when (and (numberp low) (numberp high)
                               (not (<= low high)))
                      (setq low 0 high 0)) ; type equivalent to NIL
                    (yes))
                  (unknown))))
             (INTEGER
              (let ((low (if (rest type) (second type) '*))
                    (high (if (cddr type) (third type) '*)))
                (when (consp low)
                  (setq low (first low))
                  (when (numberp low) (incf low)))
                (when (consp high)
                  (setq high (first high))
                  (when (numberp high) (decf high)))
                (when (and (numberp low) (numberp high) (not (<= low high)))
                  (setq low 0 high 0)) ; type equivalent to NIL
                (yes)))
             (INTERVALS
              (if (eq (second type) 'INTEGER)
                (let ((low (third type))
                      (high (car (last type))))
                  (when (consp low)
                    (setq low (first low))
                    (when (numberp low) (incf low)))
                  (when (consp high)
                    (setq high (first high))
                    (when (numberp high) (decf high)))
                  (yes))
                (unknown)))
             (MOD ; (MOD n)
              (let ((n (second type)))
                (unless (and (integerp n) (>= n 0))
                  (typespec-error 'subtypep type))
                (if (eql n 0)
                  (no)
                  (let ((low 0) (high (1- n)))
                    (yes)))))
             (SIGNED-BYTE ; (SIGNED-BYTE &optional s)
              (let ((s (if (cdr type) (second type) '*)))
                (if (eq s '*)
                  (let ((low '*) (high '*)) (yes))
                  (progn
                    (unless (and (integerp s) (plusp s))
                      (typespec-error 'subtypep type))
                    (let ((n (ash 1 (1- s)))) ; (ash 1 *) == (expt 2 *)
                      (let ((low (- n)) (high (1- n)))
                        (yes)))))))
             (UNSIGNED-BYTE ; (UNSIGNED-BYTE &optional s)
              (let ((s (if (cdr type) (second type) '*)))
                (if (eq s '*)
                    (let ((low 0) (high '*)) (yes))
                    (progn
                      (unless (and (integerp s) (>= s 0))
                        (typespec-error 'subtypep type))
                      (let ((n (ash 1 s))) ; (ash 1 *) == (expt 2 *)
                        (let ((low 0) (high (1- n)))
                          (yes)))))))
             (t (no))))
          ((clos::defined-class-p type)
           (if (and (clos::built-in-class-p type)
                    (eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type))
             (return-from subtype-integer
               (subtype-integer (clos:class-name type)))
             (no)))
          ((clos::eql-specializer-p type)
           (let ((x (clos::eql-specializer-singleton type)))
             (if (typep x 'INTEGER)
               (let ((low (min 0 x)) (high (max 0 x))) (yes))
               (no))))
          ((encodingp type) (no))
          (t (typespec-error 'subtypep type)))))

#| TODO: Fix subtype-integer such that this works.
Henry Baker:
 (defun type-null (x)
  (values (and (eq 'bit (upgraded-array-element-type `(or bit ,x)))
               (not (typep 0 x))
               (not (typep 1 x)))
          t))
 (type-null '(and symbol number))
 (type-null '(and integer symbol))
 (type-null '(and integer character))
|#

;; Determines a sequence kind (an atom, as defined in defseq.lisp: one of
;;   LIST - stands for LIST
;;   VECTOR - stands for (VECTOR T)
;;   STRING - stands for (VECTOR CHARACTER)
;;   1, 2, 4, 8, 16, 32 - stands for (VECTOR (UNSIGNED-BYTE n))
;;   0 - stands for (VECTOR NIL))
;; that indicates the sequence type meant by the given type. Other possible
;; return values are
;;   SEQUENCE - denoting a type whose intersection with (OR LIST VECTOR) is not
;;              subtype of LIST or VECTOR, or
;;   NIL - indicating a type whose intersection with (OR LIST VECTOR) is empty.
;; When the type is (OR (VECTOR eltype1) ... (VECTOR eltypeN)), the chosen
;; element type is the smallest element type that contains all of eltype1 ...
;; eltypeN.
;;
;; User-defined sequence types are not supported here.
;;
;; This implementation inlines the (tail-recursive) canonicalize-type
;; function. Its advantage is that it doesn't cons as much. Also it employs
;; some heuristics and does not have the full power of SUBTYPEP.
(defun subtype-sequence (type)
  (setq type (expand-deftype type))
  (cond ((symbolp type)
         (case type
           ((LIST CONS NULL) 'LIST)
           ((NIL) 'NIL)
           ((BIT-VECTOR SIMPLE-BIT-VECTOR) '1)
           ((STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING) 'STRING)
           ((VECTOR SIMPLE-VECTOR ARRAY SIMPLE-ARRAY) 'VECTOR)
           ((SEQUENCE) 'SEQUENCE)
           (t 'NIL)))
        ((and (consp type) (symbolp (first type)))
         (unless (and (list-length type) (null (cdr (last type))))
           (typespec-error 'subtypep type))
         (case (first type)
           (MEMBER ; (MEMBER &rest objects)
            (let ((kind 'NIL))
              (dolist (x (rest type))
                (setq kind (sequence-type-union kind (type-of-sequence x))))
              kind))
           (EQL ; (EQL object)
            (unless (eql (length type) 2)
              (typespec-error 'subtypep type))
            (type-of-sequence (second type)))
           (OR ; (OR type*)
            (let ((kind 'NIL))
              (dolist (x (rest type))
                (setq kind (sequence-type-union kind (subtype-sequence x))))
              kind))
           (AND ; (AND type*)
            (let ((kind 'SEQUENCE))
              (dolist (x (rest type))
                (setq kind (sequence-type-intersection kind (subtype-sequence x))))
              kind))
           ((SIMPLE-BIT-VECTOR BIT-VECTOR) ; (SIMPLE-BIT-VECTOR &optional size)
            (when (cddr type)
              (typespec-error 'subtypep type))
            '1)
           ((SIMPLE-STRING STRING SIMPLE-BASE-STRING BASE-STRING) ; (SIMPLE-STRING &optional size)
            (when (cddr type)
              (typespec-error 'subtypep type))
            'STRING)
           (SIMPLE-VECTOR ; (SIMPLE-VECTOR &optional size)
            (when (cddr type)
              (typespec-error 'subtypep type))
            'VECTOR)
           ((VECTOR ARRAY SIMPLE-ARRAY) ; (VECTOR &optional el-type size), (ARRAY &optional el-type dimensions)
            (when (cdddr type)
              (typespec-error 'subtypep type))
            (let ((el-type (if (cdr type) (second type) '*)))
              (if (eq el-type '*)
                'VECTOR
                (let ((eltype (upgraded-array-element-type el-type)))
                  (cond ((eq eltype 'T) 'VECTOR)
                        ((eq eltype 'CHARACTER) 'STRING)
                        ((eq eltype 'BIT) '1)
                        ((and (consp eltype) (eq (first eltype) 'UNSIGNED-BYTE)) (second eltype))
                        ((eq eltype 'NIL) '0)
                        (t (error (TEXT "~S is not up-to-date with ~S for element type ~S")
                                  'subtypep-sequence 'upgraded-array-element-type eltype)))))))
           ((CONS) ; (CONS &optional cartype cdrtype)
            (when (cdddr type)
              (typespec-error 'subtypep type))
            'LIST)
           (t 'NIL)))
        ((clos::defined-class-p type)
         (if (and (clos::built-in-class-p type)
                  (eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type))
           (subtype-sequence (clos:class-name type))
           'NIL))
        ((clos::eql-specializer-p type)
         (type-of-sequence (clos::eql-specializer-singleton type)))
        (t 'NIL)))
(defun type-of-sequence (x)
  (cond ((listp x) 'LIST)
        ((vectorp x)
         (let ((eltype (array-element-type x)))
           (cond ((eq eltype 'T) 'VECTOR)
                 ((eq eltype 'CHARACTER) 'STRING)
                 ((eq eltype 'BIT) '1)
                 ((and (consp eltype) (eq (first eltype) 'UNSIGNED-BYTE)) (second eltype))
                 ((eq eltype 'NIL) '0)
                 (t (error (TEXT "~S is not up-to-date with ~S for element type ~S")
                           'type-of-sequence 'array-element-type eltype)))))
        (t 'NIL)))
(defun sequence-type-union (t1 t2)
  (cond ; Simple general rules.
        ((eql t1 t2) t1)
        ((eq t1 'NIL) t2)
        ((eq t2 'NIL) t1)
        ; Now the union of two different types.
        ((or (eq t1 'SEQUENCE) (eq t2 'SEQUENCE)) 'SEQUENCE)
        ((or (eq t1 'LIST) (eq t2 'LIST))
         ; union of LIST and a vector type
         'SEQUENCE)
        ((or (eq t1 'VECTOR) (eq t2 'VECTOR)) 'VECTOR)
        ((eql t1 0) t2)
        ((eql t2 0) t1)
        ((or (eq t1 'STRING) (eq t2 'STRING))
         ; union of STRING and an integer-vector type
         'VECTOR)
        (t (max t1 t2))))
(defun sequence-type-intersection (t1 t2)
  (cond ; Simple general rules.
        ((eql t1 t2) t1)
        ((or (eq t1 'NIL) (eq t2 'NIL)) 'NIL)
        ; Now the intersection of two different types.
        ((eq t1 'SEQUENCE) t2)
        ((eq t2 'SEQUENCE) t1)
        ((or (eq t1 'LIST) (eq t2 'LIST))
         ; intersection of LIST and a vector type
         'NIL)
        ((eq t1 'VECTOR) t2)
        ((eq t2 'VECTOR) t1)
        ((or (eql t1 0) (eql t2 0)) '0)
        ((or (eq t1 'STRING) (eq t2 'STRING))
         ; intersection of STRING and an integer-vector type
         '0)
        (t (min t1 t2))))

;; ============================================================================

(defun type-expand (typespec &optional once-p)
  (multiple-value-bind (expanded user-defined-p)
      (expand-deftype typespec once-p)
    (if user-defined-p (values expanded user-defined-p)
      (cond ((symbolp typespec)
             (cond ((or (get typespec 'TYPE-SYMBOL) (get typespec 'TYPE-LIST))
                    (values typespec nil))
                   ((or (get typespec 'DEFSTRUCT-DESCRIPTION)
                        (clos-class typespec))
                    (values typespec nil))
                   (t (typespec-error 'type-expand typespec))))
            ((and (consp typespec) (symbolp (first typespec)))
             (case (first typespec)
               ((SATISFIES MEMBER EQL NOT AND OR) (values typespec nil))
               (t (cond ((get (first typespec) 'TYPE-LIST)
                         (values typespec nil))
                        (t (typespec-error 'type-expand typespec))))))
            ((clos::defined-class-p typespec) (values typespec nil))
            (t (typespec-error 'type-expand typespec))))))

;; ============================================================================

(unless (clos::funcallable-instance-p #'clos::class-name)
  (fmakunbound 'clos::class-name))