Remove all files, redirect to GitHub.HEADmaster

1 files changed, 0 insertions, 1218 deletions

diff --git a/tests/examplefiles/type.lisp b/tests/examplefiles/type.lisp
deleted file mode 100644
index c02c29df..00000000
--- a/tests/examplefiles/type.lisp
+++ /dev/null
@@ -1,1218 +0,0 @@
-;;;; 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))
-
-
-(keywordp :junk)
-  T
-
-(keywordp ::junk)
-  T
-
-(symbol-name ::junk)
-  "JUNK"
-
-(symbol-name :#junk)
-  "#JUNK"
-
-(symbol-name :#.junk)
-  "#.JUNK"