;;; 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). 
;;; **********************************************************************

;;; Open-coded type predicates for the Common Lisp Compiler.
;;; Written by Scott Fahlman and Skef Wholey.

;;; This stuff is Perq-specific.

;;; This file must be compiled immediately after XC.LSP is compiled, since
;;; it depends on macro definitions in that file.

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

;;; Note -- the following type predicates are not open coded:
;;;   COMMONP, STRING-CHARP, STANDARD-CHARP

(defprimitive consp consp)
(defprimitive listp listp)
(defprimitive atom atom)
(defprimitive symbolp symbolp)
(defprimitive simple-vector-p simple-vector-p)
(defprimitive vectorp vectorp)
(defprimitive simple-string-p simple-string-p)
(defprimitive stringp stringp)
(defprimitive simple-bit-vector-p simple-bit-vector-p)
(defprimitive bit-vector-p bit-vector-p)
(defprimitive arrayp arrayp)

;;; Crocks that can go away sometime real soon:

(defprimitive slisp-b-vector-p simple-vector-p)

(defprimitive slisp-u-vector simple-integer-vector-p)

(deftransform slisp-vector-p slisp-vector-p-transform (arg)
  (once-only ((a arg))
    `(and (arrayp ,a) (not (%primitive complex-array-p ,a)))))

(defprimitive slisp-array-p complex-array-p)

;;; --- End of crocks.

(deftransform sequencep sequencep-transform (arg)
  (once-only ((a arg))
    `(or (vectorp ,a) (listp ,a))))

(deftransform functionp functionp-transform (arg)
  (once-only ((a arg))
    `(or (compiled-function-p ,a)
	 (and (listp ,a)
	      (memq (car ,a) '(lambda %compiled-closure% %lexical-closure%))))))
		
(deftransform structurep structurep-transform (arg)
  (once-only ((a arg))
    `(and (simple-vector-p ,a)
	  (= (%primitive get-vector-subtype ,a) 1))))

(defprimitive characterp characterp)
(defprimitive numberp numberp)
(defprimitive floatp floatp)
(defprimitive integerp integerp)
(defprimitive fixnump fixnump)
(defprimitive bignump bignump)

(deftransform bitp bitp-transform (arg)
  (once-only ((a arg))
    `(or (eq ,a 0) (eq ,a 1))))

(defprimitive short-floatp short-float-p)
(defprimitive single-floatp short-float-p)
(defprimitive long-floatp long-float-p)
(defprimitive double-floatp long-float-p)
(defprimitive complexp complexp)
(defprimitive ratiop ratiop)
(defprimitive compiled-function-p compiled-function-p)
(defprimitive rationalp rationalp)

;;; Processor for ZEROP.  Do this as a CG processor instead of a transform
;;; so that the indicator cases can be handled by the conditional processors.
;;; This catches the remaining odd cases.

(def-cg zerop cg-zerop (arg)
  (cg-form arg t)
  (inst-out `(= (short-const 0))))


;;; Open code TYPEP if type specifier is constant and simple.

(defvar typep-conversions
  '((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-charp)
    (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)))

(deftransform typep typep-transform (obj type)
  (let ((temp (transform type)))
    (cond ((eq temp 't) t)
	  ((equal temp '(quote t)) t)
	  ((null temp) nil)
	  ((equal temp '(quote nil)) nil)
	  ((and (listp temp)
		(eq (car temp) 'quote)
		(symbolp (setq temp (cadr temp))))
	   (if (setq temp (assq temp typep-conversions))
	       `(,(cdr temp) ,obj)    
	       `(structure-typep ,obj ,type)))
	  (t '%pass%))))