;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.

;;;;  Copyright (c) 2012-2013, Jean-Claude Beaudoin.

;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Lesser General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 3 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../../Copyright' for full details.

;;;;                              predicate routines

(in-package "SYSTEM")

(defvar *subtypep-cache* (si:make-vector t 256 nil nil nil 0))

(defvar *upgraded-array-element-type-cache* (si:make-vector t 128 nil nil nil 0))

(defun subtypep-clear-cache ()
  (si:fill-array-with-elt *subtypep-cache* nil 0 nil)
  (si:fill-array-with-elt *upgraded-array-element-type-cache* nil 0 nil))

(defun create-type-name (name)
  (when (member name *alien-declarations*)
    (error "Symbol ~s is a declaration specifier and cannot be used to name a new type" name)))

(defun do-deftype (name form function)
  (unless (symbolp name)
    (error "~s is not a valid type specifier" name))
  (create-type-name name)
  (put-sysprop name 'DEFTYPE-FORM form)
  (put-sysprop name 'DEFTYPE-DEFINITION function)
  (subtypep-clear-cache)
  name)

;;; DEFTYPE macro.
(defmacro deftype (name lambda-list &rest body)
  "Syntax: (deftype name lambda-list {decl | doc}* {form}*)
Defines a new type-specifier abbreviation in terms of an 'expansion' function
	(lambda lambda-list1 {DECL}* {FORM}*)
where LAMBDA-LIST1 is identical to LAMBDA-LIST except that all optional
parameters with no default value specified in LAMBDA-LIST defaults to the
symbol '*', but not to NIL.  When the type system of MKCL encounters a type
specifier (NAME arg1 ... argn), it calls the expansion function with the
arguments ARG1 ... ARGn, and uses the returned value instead of the original
type specifier.  When the symbol NAME is used as a type specifier, the
expansion function is called with no argument.
The doc-string DOC, if supplied, is saved as a TYPE doc and can be retrieved
by (documentation 'NAME 'type)."
  (multiple-value-bind (body doc)
      (remove-documentation body)
    (setf lambda-list (copy-list lambda-list))
    (dolist (x '(&optional &key))
      (do ((l (rest (member x lambda-list)) (rest l)))
	  ((null l))
	(let ((variable (first l)))
	  (when (and (symbolp variable)
		     (not (member variable lambda-list-keywords)))
	    (setf (first l) `(,variable '*))))))

    (let ((whole-var (gensym)) (env-var (gensym)))
      `(define-when (:compile-toplevel :load-toplevel :execute)
         ,@(si::expand-set-documentation name 'type doc)
         (do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@body)

                     #'(si::LAMBDA (,whole-var ,env-var)

                         (declare (ignorable ,env-var))
                         (destructuring-bind ,lambda-list (if (consp ,whole-var) (cdr ,whole-var) nil)

                           (block ,name
                             ,@body))))))))

;;; Some DEFTYPE definitions.
(deftype boolean ()
  "A BOOLEAN is an object which is either NIL or T."
  `(member nil t))

(deftype index ()
  `(INTEGER 0 (#.array-dimension-limit)))

(deftype fixnum ()
  "A FIXNUM is an integer between MOST-NEGATIVE-FIXNUM and
MOST-POSITIVE-FIXNUM inclusive.  Other integers are bignums."
  `(INTEGER #.most-negative-fixnum #.most-positive-fixnum))
(deftype bignum ()
  '(OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))

(deftype bit ()
  "A BIT is either integer 0 or 1."
  '(INTEGER 0 1))

(deftype mod (n)
  `(INTEGER 0 ,(1- n)))

(deftype signed-byte (&optional s)
  "As a type specifier, (SIGNED-BYTE n) specifies those integers that can be
represented with N bits in 2's complement representation."
  (if (or (null s) (eq s '*))
      '(INTEGER * *)
      `(INTEGER ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s))))))

(deftype unsigned-byte (&optional s)
  "As a type specifier, (UNSIGNED-BYTE n) specifies non-negative integers that
can be represented with N bits."
  (if (or (null s) (eq s '*))
      '(INTEGER 0 *)
      `(INTEGER 0 ,(1- (expt 2 s)))))

;; (deftype mkcl::byte8 () '(INTEGER 0 255))
;; (deftype mkcl::integer8 () '(INTEGER -128 127))
;; (deftype mkcl::byte16 () '(INTEGER 0 #xFFFF))
;; (deftype mkcl::integer16 () '(INTEGER #x-8000 #x7FFF))
;; (deftype mkcl::byte32 () '(INTEGER 0 #xFFFFFFFF))
;; (deftype mkcl::integer32 () '(INTEGER #x-80000000 #x7FFFFFFF))
;; (deftype mkcl::byte64 () '(INTEGER 0 #xFFFFFFFFFFFFFFFF))
;; (deftype mkcl::integer64 () '(INTEGER #x-8000000000000000 #x7FFFFFFFFFFFFFFF))
(deftype mkcl::byte8 () '(UNSIGNED-BYTE 8)) ;; deprecated, use natural8
(deftype mkcl::natural8 () '(UNSIGNED-BYTE 8))
(deftype mkcl::octet () '(UNSIGNED-BYTE 8))
(deftype mkcl::integer8 () '(SIGNED-BYTE 8))
(deftype mkcl::byte16 () '(UNSIGNED-BYTE 16)) ;; deprecated, use natural16
(deftype mkcl::natural16 () '(UNSIGNED-BYTE 16))
(deftype mkcl::double-octet () '(UNSIGNED-BYTE 16))
(deftype mkcl::integer16 () '(SIGNED-BYTE 16))
(deftype mkcl::byte32 () '(UNSIGNED-BYTE 32)) ;; deprecated, use natural32
(deftype mkcl::natural32 () '(UNSIGNED-BYTE 32))
(deftype mkcl::integer32 () '(SIGNED-BYTE 32))
(deftype mkcl::byte64 () '(UNSIGNED-BYTE 64)) ;; deprecated, use natural64
(deftype mkcl::natural64 () '(UNSIGNED-BYTE 64))
(deftype mkcl::integer64 () '(SIGNED-BYTE 64))
(deftype mkcl::cl-word () '(SIGNED-BYTE #.CL-WORD-BITS))
(deftype mkcl::cl-index () '(UNSIGNED-BYTE #.CL-WORD-BITS))

(deftype mkcl::octets () '(vector mkcl::octet))
(deftype mkcl::double-octets () '(vector mkcl::double-octet))

(deftype real (&optional (start '* start-p) (end '*))
  (if start-p
      (let (rat-start
	    real-start
	    rat-end
	    real-end)
	(cond ((consp start)
	       (setf start (first start)
		     rat-start (list (rational start))
		     real-start (list (float start))))
	      ((numberp start)
	       (setf rat-start (rational start)
		     real-start (float start)))
	      (t
	       (setf rat-start start
		     real-start start)))
	(cond ((consp end)
	       (setf end (first end)
		     rat-end (list (rational end))
		     real-end (list (float end))))
	      ((numberp end)
	       (setf rat-end (rational end)
		     real-end (float end)))
	      (t
	       (setf rat-end end
		     real-end end)))
	`(OR (RATIONAL ,rat-start ,rat-end) (FLOAT ,real-start ,real-end)))
      '(OR RATIONAL FLOAT)))

#-short-float
(deftype short-float (&rest args)
  (if args
      `(single-float ,@args)
      'single-float))

#-long-float
(deftype long-float (&rest args)
  (if args
      `(double-float ,@args)
      'double-float))

(deftype null ()
  "The type to which only NIL belongs."

  '(EQL NIL))

(deftype sequence ()
  "A sequence is either a list or a vector."
  ;;'(OR CONS NULL (ARRAY * (*)))
  '(OR CONS NULL VECTOR)
  )

(deftype list ()
  "As a type specifier, LIST is used to specify the type consisting of NIL and
cons objects.  In our ordinary life with Lisp, however, a list is either NIL
or a cons whose cdr is a list, and is notated by its elements surrounded with
parentheses.
The backquote macro is sometimes useful to construct a complicated list
structure.  When evaluating `(...)
	,form embeds the value of FORM,
	,@form and ,.form embed all elements of the list value of FORM,
	and other things embed itself
into the structure at their position.  For example,
	`(a b ,c d e) expands to (list* 'a 'b c '(d e))
	`(a b ,@c d e) expands to (list* 'a 'b (append c '(d e)))
	`(a b ,.c d e) expands to (list* 'a 'b (nconc c '(d e)))"
  '(OR CONS NULL))

(deftype proper-list ()
  '(OR (CONS T PROPER-LIST) NULL))

(deftype property-list ()
  '(OR (CONS T (CONS T PROPERTY-LIST)) NULL))

(deftype atom ()
  "An ATOM is an object that is not a CONS."
  '(NOT CONS))

(deftype vector (&optional (element-type '*) (size '*))
  "A vector is a one-dimensional array.  Strings and bit-vectors are kinds of
vectors.  Other vectors are called general vectors and are notated as
	#(elem ... elem)
Some vectors may be displaced to another array, may have a fill-pointer, or
may be adjustable.  Other vectors are called simple-vectors."
  `(array ,element-type (,size)))

(deftype extended-char ()
  "A character which is not of type BASE-CHAR."
  '(and character (not base-char)))

(deftype string (&optional size)
  "A string is a vector of characters.  A string is notated by surrounding the
characters with double quotes.  Some strings may be displaced to another
string, may have a fill-pointer, or may be adjustable.  Other strings are
called simple-strings."
  #-unicode
  (if size `(array character (,size)) '(array character (*)))
  #+unicode
  (if size
      `(or (array base-char (,size))
	   (array character (,size)))
      '(or (array base-char (*)) (array character (*)))))

(deftype base-string (&optional size)
  "A string which is made of BASE-CHAR."
  (if size `(array base-char (,size)) '(array base-char (*))))

(deftype extended-string (&optional size)
  "A string which is nt a base string"
  #-unicode (declare (ignore size))
  #-unicode
  NIL
  #+unicode
  (if size `(array character (,size)) '(array character (*))))

(deftype bit-vector (&optional size)
  "A bit-vector is a vector of bits.  A bit-vector is notated by '#*' followed
by its elements (0 or 1).  Bit-vectors may be displaced to another array, may
have a fill-pointer, or may be adjustable.  Other bit-vectors are called
simple-bit-vectors.  Only simple-bit-vectors can be input in the above format
using '#*'."
  (if size `(array bit (,size)) '(array bit (*))))

(deftype simple-vector (&optional size)
  "A simple-vector is a vector that is not displaced to another array, has no
fill-pointer, and is not adjustable."
  (if size `(simple-array t (,size)) '(simple-array t (*))))

(deftype simple-string (&optional size)
  "A simple-string is a string that is not displaced to another array, has no
fill-pointer, and is not adjustable."
  #-unicode
  (if size
    `(simple-array character (,size))
    '(simple-array character (*)))
  #+unicode
  (if size
      `(or (simple-array base-char (,size))
	   (simple-array character (,size)))
      '(or (simple-array base-char (*)) (simple-array character (*)))))

(deftype simple-base-string (&optional size)
  "A base-string which cannot be adjusted nor displaced."
  (if size `(simple-array base-char (,size)) '(simple-array base-char (*))))

(deftype simple-bit-vector (&optional size)
  "A bit-vector that is not displaced to another array, has no fill-pointer,
and is not adjustable."
  (if size `(simple-array bit (,size)) '(simple-array bit (*))))


(deftype encoded-string ()
  `(or utf-8 utf-16))


;;************************************************************
;;			TYPEP
;;************************************************************

(defun constantly-t (&rest foo)
  (declare (ignore foo))
  t)

(defun constantly-nil (&rest foo)
  (declare (ignore foo))
  nil)

(defun simple-array-p (x)
  (and (arrayp x)
       (not (adjustable-array-p x))
       (not (array-has-fill-pointer-p x))
       (not (array-displacement x))))

(eval-when (:execute :load-toplevel :compile-toplevel)
  (defconstant +known-typep-predicates+
    '((ARRAY . ARRAYP)
      (ATOM . ATOM)
      (BASE-CHAR . BASE-CHAR-P)
      (BASE-STRING . BASE-STRING-P)
      ;(BIGNUM . SI::BIGNUMP)
      (BIT-VECTOR . BIT-VECTOR-P)
      (CHARACTER . CHARACTERP)
      (COMPILED-FUNCTION . COMPILED-FUNCTION-P)
      (COMPLEX . COMPLEXP)
      (CONS . CONSP)
      ;(DOUBLE-FLOAT . SI::DOUBLE-FLOAT-P)
      #-unicode
      (EXTENDED-CHAR . CONSTANTLY-NIL)
      (FLOAT . FLOATP)
      (FUNCTION . FUNCTIONP)
      (HASH-TABLE . HASH-TABLE-P)
      (INTEGER . INTEGERP)
      (FIXNUM . SI::FIXNUMP)
      (KEYWORD . KEYWORDP)
      (LIST . LISTP)
      (LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
      ;#+long-float
      ;(LONG-FLOAT . SI::LONG-FLOAT-P)
      (NIL . CONSTANTLY-NIL)
      (NULL . NULL)
      (NUMBER . NUMBERP)
      (PACKAGE . PACKAGEP)
      (PATHNAME . PATHNAMEP)
      (RANDOM-STATE . RANDOM-STATE-P)
      ;(RATIO . SI::RATIOP)
      (RATIONAL . RATIONALP)
      (READTABLE . READTABLEP)
      (REAL . REALP)
      (SIMPLE-ARRAY . SIMPLE-ARRAY-P)
      (SIMPLE-BASE-STRING . SIMPLE-BASE-STRING-P)
      (SIMPLE-STRING . SIMPLE-STRING-P)
      (SIMPLE-VECTOR . SIMPLE-VECTOR-P)
      (SIMPLE-BIT-VECTOR . SIMPLE-BIT-VECTOR-P)
      ;(SINGLE-FLOAT . SI::SINGLE-FLOAT-P)
      (STREAM . STREAMP)
      (STRING . STRINGP)
      (STRUCTURE . SYS:STRUCTUREP)
      (SYMBOL . SYMBOLP)
      (T . CONSTANTLY-T)
      (VECTOR . VECTORP))))

(dolist (l +known-typep-predicates+)
  (put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))

(defconstant +upgraded-array-element-types+
  '#.(append '(NIL BASE-CHAR #+unicode CHARACTER BIT MKCL:INTEGER8 MKCL:NATURAL8)
             '(MKCL:INTEGER16 MKCL:NATURAL16)
             '(MKCL:INTEGER32 MKCL:NATURAL32)
             (when (< 32 cl-word-bits 64) '(MKCL::CL-WORD MKCL::CL-INDEX))
             '(MKCL:INTEGER64 MKCL:NATURAL64)
             (when (< 64 cl-word-bits) '(MKCL::CL-WORD MKCL::CL-INDEX))
             '(SINGLE-FLOAT DOUBLE-FLOAT T)))

(defconstant +fixed-array-element-types+
  '#.(append '(FIXNUM)
	     (unless (< 64 cl-word-bits) '(MKCL::CL-WORD MKCL::CL-INDEX))))

(defun upgraded-array-element-type (element-type &optional env)
  (declare (ignore env))
  (let* ((hash (logand 127 (si:hash-eql element-type)))
	 (record (aref *upgraded-array-element-type-cache* hash)))
    (declare (type (integer 0 127) hash))
    (if (and record (eq (car record) element-type))
	(cdr record)
	(let ((answer (cond ((member element-type +fixed-array-element-types+ :test #'eq)
			     element-type)
			    ((member element-type +upgraded-array-element-types+ :test #'eq)
			     element-type)
			    (t
			     (dolist (v +upgraded-array-element-types+ 'T)
			       (when (subtypep element-type v)
				 (return v)))))))
	  (setf (aref *upgraded-array-element-type-cache* hash)
		(cons element-type answer))
	  answer))))

(defun upgraded-complex-part-type (real-type &optional env)
  (declare (ignore env))
  ;; MKCL does not have specialized complex types. If we had them, the
  ;; code would look as follows
  ;;   (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
  ;; 	   (error "~S is not a valid part type for a complex." real-type))
  ;;     (when (subtypep real-type v)
  ;;       (return v))))
  (unless (subtypep real-type 'REAL)
    (error "~S is not a valid part type for a complex." real-type))
  'REAL)

(defun in-interval-p (x interval)
  (let* (low high)
    (if (endp interval)
        (setq low '* high '*)
        (if (endp (cdr interval))
            (setq low (car interval) high '*)
            (setq low (car interval) high (second interval))))
    (cond ((eq low '*))
          ((consp low)
           (when (<= x (car low)) (return-from in-interval-p nil)))
          ((when (< x low) (return-from in-interval-p nil))))
    (cond ((eq high '*))
          ((consp high)
           (when (>= x (car high)) (return-from in-interval-p nil)))
          ((when (> x high) (return-from in-interval-p nil))))
    (return-from in-interval-p t)))

(defun error-type-specifier (type)
  (error "~S is not a valid type specifier." type))

(defun match-dimensions (array pat)
  (or (eq pat '*)
      (let ((rank (array-rank array)))
	(cond ((numberp pat) (= rank pat))
	      ((listp pat)
	       (dotimes (i rank (null pat))
		 (unless (and (consp pat)
			      (or (eq (car pat) '*)
				  (eql (array-dimension array i) (car pat))))
		   (return nil))
		 (setq pat (cdr pat))))
	      ((atom pat)
	       (error "~S does not describe array dimensions." pat))))))

#|
(defun typep (object type &optional env &aux tp i c)
  "Args: (object type)
Returns T if X belongs to TYPE; NIL otherwise."
  (declare (ignore env))
  (cond ((symbolp type)
	 (let ((f (get-sysprop type 'TYPE-PREDICATE)))
	   (cond (f (return-from typep (funcall f object)))
		 ((eq (type-of object) type) (return-from typep t))
		 (t (setq tp type i nil)))))
	((consp type)
	 (setq tp (car type) i (cdr type)))
	((sys:instancep type)
	 (return-from typep (si::subclassp (class-of object) type)))
	(t
	 (error-type-specifier type)))
  (case tp
    ((EQL MEMBER) (and (member object i) t))
    (NOT (not (typep object (car i))))
    (OR (dolist (e i)
	  (when (typep object e) (return t))))
    (AND (dolist (e i t)
	   (unless (typep object e) (return nil))))
    (SATISFIES (funcall (car i) object))
    ((T) t)
    ((NIL) nil)
    (BIGNUM (and (integerp object) (not (si::fixnump object))))
    (RATIO (eq (type-of object) 'RATIO))
    (STANDARD-CHAR
     (and (characterp object) (standard-char-p object)))
    (INTEGER
     (and (integerp object) (in-interval-p object i)))
    (RATIONAL
     (and (rationalp object) (in-interval-p object i)))
    (FLOAT
     (and (floatp object) (in-interval-p object i)))
    (REAL
     (and (or (rationalp object) (floatp object)) (in-interval-p object i)))
    ((SINGLE-FLOAT SHORT-FLOAT)
     (and (eq (type-of object) 'SINGLE-FLOAT) (in-interval-p object i)))
    ((DOUBLE-FLOAT #-long-float LONG-FLOAT)
     (and (eq (type-of object) 'DOUBLE-FLOAT) (in-interval-p object i)))
    #+long-float
    (LONG-FLOAT
     (and (eq (type-of object) 'LONG-FLOAT) (in-interval-p object i)))
    (COMPLEX
     (and (complexp object)
          (or (null i)
	      (and (typep (realpart object) (car i))
		   ;;wfs--should only have to check one.
		   ;;Illegal to mix real and imaginary types!
		   (typep (imagpart object) (car i))))
	   ))
    (SEQUENCE (or (listp object) (vectorp object)))
    (CONS (and (consp object)
	       (or (endp i)
		   (let ((car-type (first i)))
		     (or (eq car-type '*) (typep (car object) car-type))))
	       (or (endp (cdr i))
		   (let ((cdr-type (second i)))
		     (or (eq cdr-type '*) (typep (cdr object) cdr-type))))))

    ;;(CONS (and (consp object)
    ;;           (or (endp i) (typep (car object) (first i)))
    ;;           (or (endp (cdr i)) (typep (cdr object) (second i)))))
    (BASE-STRING
     (and (base-string-p object)
          (or (null i) (match-dimensions object i))))
    (STRING
     (and (stringp object)
          (or (null i) (match-dimensions object i))))
    (BIT-VECTOR
     (and (bit-vector-p object)
          (or (null i) (match-dimensions object i))))
    (SIMPLE-BASE-STRING
     (and (base-string-p object)
          (simple-string-p object)
	  (or (null i) (match-dimensions object i))))
    (SIMPLE-STRING
     (and (simple-string-p object)
          (or (null i) (match-dimensions object i))))
    (SIMPLE-BIT-VECTOR
     (and (simple-bit-vector-p object)
          (or (null i) (match-dimensions object i))))
    (SIMPLE-VECTOR
     (and (simple-vector-p object)
          (or (null i) (match-dimensions object i))))
    (SIMPLE-ARRAY
     (and (simple-array-p object)
          (or (endp i) (eq (car i) '*)
	      ;; (car i) needs expansion
	      (eq (array-element-type object)
		  (upgraded-array-element-type (car i))))
          (or (endp (cdr i)) (match-dimensions object (second i)))))
    (ARRAY
     (and (arrayp object)
          (or (endp i) (eq (car i) '*)
              ;; Or the element type of object should be EQUAL to (car i).
              ;; Is this too strict?
              (eq (array-element-type object)
		  (upgraded-array-element-type (car i))))
          (or (endp (cdr i)) (match-dimensions object (second i)))))
    (t
     (cond
           ((get-sysprop tp 'DEFTYPE-DEFINITION)

            (typep object (funcall (get-sysprop tp 'DEFTYPE-DEFINITION) type nil)))

	   ((consp i)
	    (error-type-specifier type))
	   ((setq c (find-class type nil))
	    ;; Follow the inheritance chain
	    (si::subclassp (class-of object) c))
#|
	   #-clos
	   ((get-sysprop tp 'IS-A-STRUCTURE)
            (when (sys:structurep object)
	      ;; Follow the chain of structure-include.
	      (do ((stp (sys:structure-name object)
			(get-sysprop stp 'STRUCTURE-INCLUDE)))
		  ((eq tp stp) t)
		(when (null (get-sysprop stp 'STRUCTURE-INCLUDE))
		  (return nil)))))
|#
	   (t
	    (error-type-specifier type))))))
|#

;;; The implementation of this key performance critical predicate, that is #'typep, is ridiculously naive!
;;; We must soon do better than this! JCB
(defun typep-in-env (object type env &aux tp i c)
  "Args: (object type env)
Returns T if X belongs to TYPE; NIL otherwise."
  ;;(declare (ignore env))
  (cond ((symbolp type)
	 (let ((f (get-sysprop type 'TYPE-PREDICATE)))
	   (cond (f (return-from typep-in-env (funcall f object)))
		 ((eq (type-of object) type) (return-from typep-in-env t))
		 (t (setq tp type i nil)))))
	((consp type)
	 (setq tp (car type) i (cdr type)))
	((sys:instancep type)
	 (return-from typep-in-env (si::subclassp (class-of object) type)))
	(t
	 (error-type-specifier type)))
  (case tp
    (EQL (if (cdr i) (error-type-specifier type) (eql object (car i))))
    (MEMBER (and (member object i) t))
    (NOT (not (typep-in-env object (car i) env)))
    (OR (dolist (e i)
	  (when (typep-in-env object e env) (return t))))
    (AND (dolist (e i t)
	   (unless (typep-in-env object e env) (return nil))))
    (SATISFIES (if (funcall (car i) object) t nil))
    ((T) t)
    ((NIL) nil)
    (BIGNUM (and (integerp object) (not (si::fixnump object))))
    (RATIO (eq (type-of object) 'RATIO))
    (STANDARD-CHAR
     (and (characterp object) (standard-char-p object)))
    (CHARACTER (characterp object))
    (INTEGER
     (and (integerp object) (in-interval-p object i)))
    (RATIONAL
     (and (rationalp object) (in-interval-p object i)))
    (FLOAT
     (and (floatp object) (in-interval-p object i)))
    (REAL
     (and (or (rationalp object) (floatp object)) (in-interval-p object i)))
    ((SINGLE-FLOAT SHORT-FLOAT)
     (and (eq (type-of object) 'SINGLE-FLOAT) (in-interval-p object i)))
    ((DOUBLE-FLOAT #-long-float LONG-FLOAT)
     (and (eq (type-of object) 'DOUBLE-FLOAT) (in-interval-p object i)))
    #+long-float
    (LONG-FLOAT
     (and (eq (type-of object) 'LONG-FLOAT) (in-interval-p object i)))
    (COMPLEX
     (and (complexp object)
          (or (null i)
	      (and (typep-in-env (realpart object) (car i) env)
		   ;;wfs--should only have to check one.
		   ;;Illegal to mix real and imaginary types!
		   (typep-in-env (imagpart object) (car i) env)))
	   ))
    (SEQUENCE (or (listp object) (vectorp object)))
#+(and)
    (CONS (and (consp object)
	       (or (endp i)
		   (let ((car-type (first i)))
		     (or (eq car-type '*) (typep-in-env (car object) car-type env))))
	       (or (endp (cdr i))
		   (let ((cdr-type (second i)))
		     (or (eq cdr-type '*) (typep-in-env (cdr object) cdr-type env))))))
#+(or)
    (CONS (and (consp object)
    	       (or (endp i) (typep-in-env (car object) (first i) env))
    	       (or (endp (cdr i)) (typep-in-env (cdr object) (second i) env))))
    (BASE-STRING
     (and (base-string-p object)
          (or (null i) (match-dimensions object i))))
    (STRING
     (and (stringp object)
          (or (null i) (match-dimensions object i))))
    (BIT-VECTOR
     (and (bit-vector-p object)
          (or (null i) (match-dimensions object i))))
    (SIMPLE-BASE-STRING
     (and (base-string-p object)
          (simple-string-p object)
	  (or (null i) (match-dimensions object i))))
    (SIMPLE-STRING
     (and (simple-string-p object)
          (or (null i) (match-dimensions object i))))
    (SIMPLE-BIT-VECTOR
     (and (simple-bit-vector-p object)
          (or (null i) (match-dimensions object i))))
    (SIMPLE-VECTOR
     (and (simple-vector-p object)
          (or (null i) (match-dimensions object i))))
    (SIMPLE-ARRAY
     (and (simple-array-p object)
          (or (endp i) (eq (car i) '*)
	      ;; (car i) needs expansion
	      (eq (array-element-type object)
		  (upgraded-array-element-type (car i))))
          (or (endp (cdr i)) (match-dimensions object (second i)))))
    (ARRAY
     (and (arrayp object)
          (or (endp i) (eq (car i) '*)
              ;; Or the element type of object should be EQUAL to (car i).
              ;; Is this too strict?
              (eq (array-element-type object)
		  (upgraded-array-element-type (car i))))
          (or (endp (cdr i)) (match-dimensions object (second i)))))
    (t
     (let ((deftype-def (get-sysprop tp 'DEFTYPE-DEFINITION)))
       (cond (deftype-def

	       (typep-in-env object (funcall deftype-def type env) env))

	     ((consp i)
	      (error-type-specifier type))
	     ((setq c (find-class type nil))
	      ;; Follow the inheritance chain
	      (si::subclassp (class-of object) c))
	     #|
	     #-clos
	     ((get-sysprop tp 'IS-A-STRUCTURE)
	     (when (sys:structurep object)
	     ;; Follow the chain of structure-include. ;
	     (do ((stp (sys:structure-name object)
	     (get-sysprop stp 'STRUCTURE-INCLUDE)))
	     ((eq tp stp) t)
	     (when (null (get-sysprop stp 'STRUCTURE-INCLUDE))
	     (return nil)))))
	     |#
	     (t
	      (error-type-specifier type)))))))

(defun typep (object type &optional env)
  (typep-in-env object type env))


(declaim (ftype (function (class class) boolean) subclassp))
(defun subclassp (low high)
  (or (eq low high)
      (dolist (class (sys:instance-ref low 1)) ; (class-superiors low)

	(when (subclassp class high) (return t)))))

(defun of-class-p (object class)
  (declare (optimize (speed 3)))
  (macrolet ((class-precedence-list (x)
	       `(instance-ref ,x 4))
	     (class-name (x)
	       `(instance-ref ,x 0)))
    (let* ((x-class (class-of object)))
      (declare (class x-class))
      (if (eq x-class class)
	  t
	  (let ((x-cpl (class-precedence-list x-class)))
	    (if (instancep class)
		(member class x-cpl :test #'eq)
		(dolist (c x-cpl nil)
		  (declare (type (or null class) c))
		  (when (eq (class-name c) class)
		    (return t)))))))))


;;************************************************************
;;			NORMALIZE-TYPE
;;************************************************************
;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
;; The result is a pair of values
;;  VALUE-1 = normalized type name or object
;;  VALUE-2 = normalized type arguments or nil
(defun normalize-type (type &aux tp i fd)
  ;; Loops until the car of type has no DEFTYPE definition.
  (cond ((symbolp type)
	 (if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION))

	   (normalize-type (funcall fd type nil))

	   (values type nil)))
	((clos::classp type) (values type nil))
	((atom type)
	 (error-type-specifier type))
	((progn
	   (setq tp (car type) i (cdr type))
	   (setq fd (get-sysprop tp 'DEFTYPE-DEFINITION)))

	 (normalize-type (funcall fd type nil)))

	((and (eq tp 'INTEGER) (consp (cadr i)))
	 (values tp (list (car i) (1- (caadr i)))))
	(t (values tp i))))

(defun expand-deftype (type)
  (cond ((symbolp type)
	 (let ((fd (get-sysprop type 'DEFTYPE-DEFINITION)))
	   (if fd

	       (expand-deftype (funcall fd type nil))

	       type)))
	((and (consp type)

	      (symbolp (first type)))

	 (let ((fd (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
	   (if fd

	       (expand-deftype (funcall fd type nil))

	       type)))
	(t
	 type)))

;;************************************************************
;;			COERCE
;;************************************************************

#|

(defun error-coerce (object type)
  (error "Cannot coerce ~S to type ~S." object type))

|#

(defun error-coerce (object type)
  (error 'simple-type-error
	 :datum object
	 :expected-type type
	 :format-control "Cannot coerce ~S to type ~S."
	 :format-arguments (list object type)))

(defun coerce (object type &aux aux)
  "Args: (x type)
Coerces X to an object of the specified type, if possible.  Signals an error
if not possible."
  (when (typep-in-env object type nil)
    ;; Just return as it is.
    (return-from coerce object))
  (cond ((atom type)
	 (case type
	   ((T) object)
	   (LIST
	    (do ((io (make-seq-iterator object) (seq-iterator-next object io))
	         (l nil (cons (seq-iterator-ref object io) l)))
	        ((null io) l)))

           (BASE-CHAR (let ((new (character object))) (if (mkcl:base-char-p new) new (error-coerce object type))))
	   (CHARACTER(character object))

	   (FLOAT (float object))
	   (SINGLE-FLOAT (float object 0.0F0))
	   (SHORT-FLOAT (float object 0.0S0))
	   (DOUBLE-FLOAT (float object 0.0D0))
	   (LONG-FLOAT (float object 0.0L0))
	   (COMPLEX (complex (realpart object) (imagpart object)))
	   (FUNCTION (coerce-to-function object))
	   ((VECTOR SIMPLE-VECTOR
	     #+unicode SIMPLE-BASE-STRING SIMPLE-STRING
	     #+unicode BASE-STRING STRING
	     BIT-VECTOR SIMPLE-BIT-VECTOR)
	    (concatenate type object))
	   (t

	    (if (and (or (subtypep type 'list) (subtypep type 'vector))
                     (or (listp object) (vectorp object)))

		(concatenate type object)

              (let ((expanded-type (expand-deftype type)))
                (if (not (eq type expanded-type))
                    (coerce object expanded-type)
                  (error-coerce object type)))))))

	((eq (setq aux (first type)) 'COMPLEX)

	 (if (second type)

	     (complex (coerce (realpart object) (second type))
		      (coerce (imagpart object) (second type)))
	     (complex (realpart object) (imagpart object))))
	((member aux '(SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT FLOAT))
	 (setq aux (coerce object aux))
	 (unless (typep-in-env aux type nil)
	   (error-coerce object type))
	 aux)

        #-(and) ;; not in the spec.

	((eq aux 'AND)
	 (dolist (type (rest type))
	   (setq aux (coerce aux type)))
	 (unless (typep-in-env aux type nil)
	   (error-coerce object type))
	 aux)

	((and (or (subtypep type 'list) (subtypep type 'vector))
              (or (listp object) (vectorp object)))

	 (concatenate type object))
	(t

         (let ((expanded-type (expand-deftype type)))
           (if (not (eq type expanded-type))
               (coerce object expanded-type)
             (error-coerce object type))))))