Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

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

;;; Dec-20 version maintained by Dave Steiner.

;;; See also the files SEQTRAN.CLISP (efficiency transforms for
;;; sequence and list functions), TRANS.CLISP (general transforms),
;;; and TYPETRAN.CLISP (implementation-specific transforms for type
;;; predicates).

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

;;; Note -- the following type predicates are not open coded:
;;;   COMMONP, STRING-CHARP, STANDARD-CHARP (and others).

(defprimitive consp consp)		        ; CONSP
;(defprimitive listp listp)		        ; LISTP
(defprimitive atom atom)		        ; ATOMP
;(defprimitive symbolp symbolp)		        ; SYMBP
;(defprimitive simple-vector-p simple-vector-p)	; SIMVEC
;(defprimitive vectorp vectorp)		        ; VECTRP
(defprimitive simple-string-p simple-string-p)	; SIMSTR
;(defprimitive stringp stringp)		        ; STRNGP
(defprimitive simple-bit-vector-p simple-bit-vector-p)	; SIMBVC
;(defprimitive bit-vector-p bit-vector-p)	; BITVCP
;(defprimitive arrayp arrayp)		        ; ARRAYP


(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%))))))

(defprimitive characterp characterp)	; CHRP
;(defprimitive numberp numberp)		; NUMP
(defprimitive floatp floatp)		; FLOATP
;(defprimitive integerp integerp)	; INTP
;(defprimitive fixnump fixnump)		; FXNUMP
(defprimitive bignump bignump)		; BIGNMP

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

(defprimitive short-floatp short-float-p)	; SHTFLP
(defprimitive single-floatp short-float-p)	; SHTFLP
(defprimitive long-floatp long-float-p)	        ; LNGFLP
(defprimitive double-floatp long-float-p)	; LNGFLP
;(defprimitive complexp complexp)
(defprimitive ratiop ratiop)		        ; RATIOP
;(defprimitive rationalp rationalp)	        ; RATNLP

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

(defparameter 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%))))