;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

;;; Predicate functions for Spice Lisp.
;;; The type predicates are implementation-specific.  A different version
;;;   of this file will be required for implementations with different
;;;   data representations.

;;; Written and currently maintained by Scott Fahlman.
;;; Based on an earlier version by Joe Ginder.

;;; *******************************************************************


;;; Data type predicates.

;;; Translation from type keywords to specific predicates.  Assumes that
;;; the following are named structures and need no special type hackery:
;;; PATHNAME, STREAM, READTABLE, PACKAGE, HASHTABLE, RANDOM-STATE.

(defconstant type-pred-alist
  '((common . commonp)
    (null . null)
    (cons . consp)
    (list . listp)
    (symbol . symbolp)
    (array . arrayp)
    (vector . vectorp)
    (bit-vector . bit-vector-p)
    (string . stringp)
    (sequence . sequencep)
    (simple-vector . simple-vector-p)
    (simple-string . simple-string-p)
    (simple-bit-vector . simple-bit-vector-p)
    (function . functionp)
    (compiled-function . compiled-function-p)
    (character . characterp)
    (number . numberp)
    (rational . rationalp)
    (float . floatp)
    (string-char . string-char-p)
    (integer . integerp)
    (ratio . ratiop)
    (short-float . short-floatp)
    (standard-char . standard-charp)
    (fixnum . fixnump)
    (complex . complexp)
    (single-float . single-floatp)
    (bignum . bignump)
    (double-float . double-floatp)
    (bit . bitp)
    (long-float . long-floatp)
    (structure . structurep)
    (atom . atom)))


;;;; TYPE-OF and auxiliary functions.

(defun type-of (object)
  "Returns the type of OBJECT as a type-specifier.
  Since objects may be of more than one type, the choice is somewhat
  arbitrary and may be implementation-dependent."
  (case (%primitive get-type object)
    (0 'random)
    (1 `(simple-bit-vector ,(%primitive vector-length object)))
    (2 (describe-i-vector object))
    (3 `(simple-string ,(%primitive vector-length object)))
    (4 'bignum)
    (5 'long-float)
    (6 'complex)
    (7 'ratio)
    (8 (describe-g-vector object))
    (9 'compiled-function)
    (10 (describe-array object))
    (11 'symbol)
    (12 'cons)
    ((16 17) 'fixnum)
    ((18 19) 'short-float)
    (20 'character)
    (t 'random)))

;;; Create the list-style description of a G-vector.

(defun describe-g-vector (object)
  (cond ((structurep object) (svref object 0))
	(t `(simple-vector ,(%primitive vector-length object)))))


;;; Create the list-style description of an I-vector.

(defun describe-i-vector (object)
  `(simple-array
    ,(case (%primitive get-vector-access-code object)
       (0 '(mod 2))
       (1 '(mod 4))
       (2 '(mod 16))
       (3 '(mod 256))
       (4 '(mod 65536))
       (t '?))
    ,(%primitive vector-length object)))


;;; Create the list-style description of an array.

(defun describe-array (object)
  (let ((data-vector (%primitive header-ref object %array-data-slot))
	(rank (- (%primitive header-length object) %array-first-dim-slot))
	(length (%primitive header-ref object %array-length-slot)))
    (if (= rank 1)
	(typecase data-vector
	  (simple-bit-vector `(bit-vector ,length))
	  (simple-string `(string ,length))
	  (simple-vector `(vector t ,length))
	  (t `(vector
	       ,(svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536))
		       (%primitive get-vector-access-code data-vector))
	       ,length)))
	`(array
	  ,(typecase data-vector
	     (simple-bit-vector '(mod 2))
	     (simple-string 'string-char)
	     (simple-vector 't)
	     (t (svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536))
		       (%primitive get-vector-access-code data-vector))))
	  ,(array-dimensions object)))))

;;;; TYPEP and auxiliary functions.

(defun typep (object type)
  "Returns T if OBJECT is of the specified TYPE, otherwise NIL."
  (let (temp)
    (cond ((symbolp type)
	   (cond ((eq type 't) t)
		 ((eq type 'nil) nil)
		 ((setq temp (assq type type-pred-alist))
		  (funcall (cdr temp) object))
		 (t (structure-typep object type))))
	  ((listp type) 
	   ;; This handles list-style type specifiers.
	   (case (car type)
	     (vector (and (vectorp object)
			  (vector-eltype object (cadr type))
			  (test-length object (caddr type))))
	     (simple-vector (and (simple-vector-p object)
				 (vector-eltype object (cadr type))
				 (test-length object (caddr type))))
	     (string (and (stringp object)
			  (test-length object (cadr type))))
	     (simple-string (and (simple-string-p object)
				 (test-length object (cadr type))))
	     (bit-vector (and (bit-vector-p object)
			      (test-length object (cadr type))))
	     (simple-bit-vector (and (simple-bit-vector-p object)
				     (test-length object (cadr type))))
	     (array (array-typep object type))
	     (satisfies (funcall (cadr type) object))
	     (member (member object (cdr type)))
	     (not (not (typep object (cadr type))))
	     (or (dolist (x (cdr type) nil)
		   (if (typep object x) (return t))))
	     (and (dolist (x (cdr type) t)
		    (if (not (typep object x)) (return nil))))
	     (integer (and (integerp object) (test-limits object type)))
	     (rational (and (rationalp object) (test-limits object type)))
	     (float (and (floatp object) (test-limits object type)))
	     (short-float (and (short-floatp object)
			       (test-limits object type)))
	     (single-float (and (single-floatp object)
				(test-limits object type)))
	     (double-float (and (double-floatp object)
				(test-limits object type)))
	     (long-float (and (long-floatp object)
			      (test-limits object type)))
	     (mod (and (integerp object)
		       (>= object 0)
		       (< object (cadr type))))
	     (signed-byte (and (integerp object)
			       (> (cadr type) (integer-length object))))
	     (unsigned-byte (and (integerp object)
			       (>= (cadr type) (integer-length object))))
	     ;; No complex numbers yet.
	     (complex nil)
	     (t (error "~S -- Illegal type specifier to TYPEP."  type))))
	  (t (error "~S -- Illegal type specifier to TYPEP."  type)))))


;;; This is called if the type-specifier is a symbol and is not one of the
;;; built-in Lisp types.  See if the object is a user-defined structure
;;; with the given name.

(defun structure-typep (object type)
  (cond ((get type 'defstruct-description)
	 (and (structurep object)
	      (eq type (svref object 0))))
	(t (error "~S unknown type specifier." type))))


;;; Given that the object is a vector of some sort, and that we've already
;;; verified that it matches CAR of TYPE, see if the rest of the type
;;; specifier wins.

(defun vector-eltype (object eltype)
  (let (temp)
    (cond ((null eltype) t)
	  ((eq eltype '*) t)
	  ((eq eltype 'string-char)
	   (stringp object))
	  ((eq eltype 'bit)
	   (bit-vector-p object))
	  (t (and (listp (setq temp (type-of object)))
		  (equal eltype (if (eq (car temp) 'simple-vector)
				    t
				    (cadr temp))))))))


;;; Test sequence for specified length.

(defun test-length (object length)
  (or (null length)
      (eq length '*)
      (= length (length object))))


;;; See if object satisfies the specifier for an array.

(defun array-typep (object type)
  (let ((eltype (cadr type))
	(dims (caddr type))
	(temp))
    (and (arrayp object)
	 (cond ((null eltype) t)
	       ((eq eltype '*) t)
	       ((eq eltype 'string-char)
		(or (simple-string-p object)
		    (simple-string-p (%primitive header-ref object
						 %array-data-slot))))
	       ((eq eltype 'bit)
		(and (listp (setq temp (type-of object)))
		     (equal (cadr temp) '(mod 2))))
	       (t (and (listp (setq temp (type-of object)))
		       (equal eltype (if (eq (car temp) 'simple-vector)
					 t
					 (cadr temp))))))
	 (or (null dims)
	     (eq dims '*)
	     (do ((s dims (cdr s))
		  (d (if (vectorp object)
			 (list (length object))
			 (caddr (type-of object)))
		     (cdr d)))
		 ((atom s) (atom d))
	       (cond ((atom d) (return nil))
		     ((eq (car s) '*))
		     ((eql (car s) (car d)))
		     (t (return nil))))))))


;;; Test whether a number falls within the specified limits.

(defun test-limits (object type)
  (let ((low (cadr type))
	(high (caddr type)))
    (and (cond ((null low) t)
	       ((eq low '*) t)
	       ((numberp low) (>= object low))
	       ((and (consp low) (numberp (car low)))
		(> object (car low)))
	       (t nil))
	 (cond ((null high) t)
	       ((eq high '*) t)
	       ((numberp high) (>= object high))
	       ((and (consp high) (numberp (car high)))
		(> object (car high)))
	       (t nil)))))


;;;; Assorted mumble-P type predicates.

(defun commonp (object)
  "Returns T if object is a legal Common-Lisp type, NIL if object is any
  sort of implementation-dependent or internal type."
  (or (structurep object)
      (let ((type-spec (type-of object)))
	(if (listp type-spec) (setq type-spec (car type-spec)))
	(memq type-spec
	      '(character fixnum short-float single-float double-float
		long-float vector string simple-vector simple-string
		bignum ratio complex compiled-function array symbol cons)))))

(defun bit-vector-p (object)
  "Returns T if the object is a bit vector, else returns NIL."
  (bit-vector-p object))

;;; The following definitions are trivial because the compiler open-codes
;;; all of these.

(defun null (object)
  "Returns T if the object is NIL, else returns NIL."
  (null object))

(defun not (object)
  "Returns T if the object is NIL, else returns NIL."
  (null object))

(defun symbolp (object)
  "Returns T if the object is a symbol, else returns NIL."
  (symbolp object))

(defun atom (object)
  "Returns T if the object is not a cons, else returns NIL.
  Note that (ATOM NIL) => T."
  (atom object))

(defun consp (object)
  "Returns T if the object is a cons cell, else returns NIL.
  Note that (CONSP NIL) => NIL."
  (consp object))

(defun listp (object)
  "Returns T if the object is a cons cell or NIL, else returns NIL."
  (listp object))

(defun numberp (object)
  "Returns T if the object is any kind of number."
  (numberp object))

(defun integerp (object)
  "Returns T if the object is an integer (fixnum or bignum), else 
  returns NIL."
  (integerp object))

(defun rationalp (object)
  "Returns T if the object is an integer or a ratio, else returns NIL."
  (rationalp object))

(defun floatp (object)
  "Returns T if the object is a floating-point number, else returns NIL."
  (floatp object))

(defun complexp (object)
  "Returns T if the object is a complex number, else returns NIL."
  (complexp object))

(defun characterp (object)
  "Returns T if the object is a character, else returns NIL."
  (characterp object))

(defun stringp (object)
  "Returns T if the object is a string, else returns NIL."
  (stringp object))

(defun simple-string-p (object)
  "Returns T if the object is a simple string, else returns NIL."
  (simple-string-p object))

(defun vectorp (object)
  "Returns T if the object is any kind of vector, else returns NIL."
  (vectorp object))

(defun simple-vector-p (object)
  "Returns T if the object is a simple vector, else returns NIL."
  (simple-vector-p object))

(defun simple-bit-vector-p (object)
  "Returns T if the object is a simple bit vector, else returns NIL."
  (simple-bit-vector-p object))

(defun arrayp (object)
  "Returns T if the argument is any kind of array, else returns NIL."
  (arrayp object))

(defun functionp (object)
  "Returns T if the object is a function, suitable for use by FUNCALL
  or APPLY, else returns NIL."
  (functionp object))

(defun compiled-function-p (object)
  "Returns T if the object is a compiled function object, else returns NIL."
  (compiled-function-p object))

(defun sequencep (object)
  "Returns T if object is a sequence, NIL otherwise."
  (sequencep object))


;;; The following are not defined at user level, but are necessary for
;;; internal use by TYPEP.

(defun structurep (object)
  (structurep object))

(defun fixnump (object)
  (fixnump object))

(defun bignump (object)
  (bignump object))

(defun bitp (object)
  (bitp object))

(defun short-floatp (object)
  (short-floatp object))

(defun single-floatp (object)
  (single-floatp object))

(defun double-floatp (object)
  (double-floatp object))

(defun long-floatp (object)
  (long-floatp object))

(defun ratiop (object)
  (ratiop object))

;;; Some silly internal things for tenser array hacking:

(defun slisp-b-vector-p (object)
  (slisp-b-vector-p object))

(defun slisp-vector-p (object)
  (slisp-vector-p object))

(defun slisp-array-p (object)
  (slisp-array-p object))

;;;; Equality Predicates.

(defun eq (x y)
  "Returns T if X and Y are the same object, else returns NIL."
  (eq x y))

(defun eql (x y)
  "Returns T if X and Y are EQ, or if they are numbers of the same
  type and precisely equal value, or if they are characters and
  are CHAR=, else returns NIL."
  (eql x y))

(defun equal (x y)
  "Returns T if X and Y are EQL or if they are structured components
  whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they
  are the same length and have indentical components.  Other arrays must be
  EQ to be EQUAL."
  (cond ((eql x y) t)
	((consp x)
	 (and (consp y)
	      (equal (car x) (car y))
	      (equal (cdr x) (cdr y))))
	((stringp x)
	 (and (stringp y) (string= x y)))
	((pathnamep x)
	 (and (pathnamep y) (equalp x y)))
	((bit-vector-p x)
	 (and (bit-vector-p y)
	      (= (length x) (length y))
	      (do ((i 0 (1+ i))
		   (length (length x)))
		  ((= i length) t)
		(or (= (bit x i)
		       (bit y i))
		    (return nil)))))
	(t nil)))


(defun equalp (x y)
  "Just like EQUAL, but more liberal in several respects.
  Numbers may be of different types, as long as the values are identical
  after coercion.  Characters may differ in alphabetic case.  Vectors and
  arrays must have identical dimensions and EQUALP elements, but may differ
  in their type restriction."
  (cond ((eql x y) t)
	((characterp x) (char-equal x y))
	((numberp x) (and (numberp y) (= x y)))
	((consp x)
	 (and (consp y)
	      (equalp (car x) (car y))
	      (equalp (cdr x) (cdr y))))
	((vectorp x)
	 (let ((length (length x)))
	   (and (vectorp y)
		(= length (length y))
		(do ((i 0 (1+ i)))
		    ((= i length) t)
		  (or (equalp (aref x i) (aref y i))
		      (return nil))))))
	((arrayp x)
	 (and (equal (caddr (type-of x)) (caddr (type-of y)))
	      (do ((i 0 (1+ i))
		   (length (%primitive header-ref x %array-fill-pointer-slot))
		   (data-vector-x (%primitive header-ref x %array-data-slot))
		   (data-vector-y (%primitive header-ref y %array-data-slot)))
		  ((= i length) t)
		(or (equalp (aref data-vector-x i)
			    (aref data-vector-y i))
		    (return nil)))))
	(t nil)))