Trailing-Edge
-
PDP-10 Archives
-
clisp
-
clisp/upsala/pred.clisp
There are no other files named pred.clisp in the archive.
;;; 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.
;;; 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.
;;; *******************************************************************
(in-package 'lisp)
(export '(typep complexp equalp type-of simple-array-p
;; Names of types...
instance array atom bignum bit bit-vector character common
compiled-function complex cons double-float fixnum float function
hash-table integer keyword list long-float nil null number ratio
rational sequence short-float signed-byte simple-array
simple-bit-vector simple-string simple-vector single-float
standard-char stream string string-char symbol t unsigned-byte vector
structure satisfies))
;;; 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-array . simple-array-p)
(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)
(stream . streamp)
(hash-table . hash-table-p)
(atom . atom)
(keyword . keywordp)))
;;;; 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 (%sp-type object)
(0 'random)
(1 `(simple-bit-vector ,(%sp-get-vector-length object)))
(2 (describe-i-vector object))
(3 `(simple-string ,(%sp-get-vector-length object)))
(4 'bignum)
(5 'double-float)
(6 'complex)
(7 'ratio)
(8 (describe-g-vector object))
(9 'compiled-function)
(10 (describe-array object))
(11 'symbol)
(12 'cons)
(13 'stream)
(14 'hash-table)
((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 ,(%sp-get-vector-length object)))))
;;; Create the list-style description of an I-vector.
(defun describe-i-vector (object)
`(simple-array
,(case (%sp-get-vector-access-type object)
(0 '(mod 2))
(1 '(mod 4))
(2 '(mod 16))
(3 '(mod 256))
(4 '(mod 65536))
(t (error "Invalid I-Vector access code: ~S"
(%sp-get-vector-access-type object))))
,(%sp-get-vector-length object)))
;;; Create the list-style description of an array.
(defun describe-array (object)
(let ((data-vector (header-ref object %array-data-slot))
(rank (- (header-length object) %array-first-dim-slot))
(length (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))
(%sp-get-vector-access-type 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))
(%sp-get-vector-access-type 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 ((type (type-expand type))
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))
(simple-array (and (not (slisp-array-p object))
(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)
(let ((n (cadr type)))
(or (not n) (eq n '*)
(> n (integer-length object))))))
(unsigned-byte
(and (integerp object)
(not (minusp object))
(let ((n (cadr type)))
(or (not n) (eq n '*)
(>= n (integer-length object))))))
;; No complex numbers yet.
(complex nil)
(t (cond ((null (cdr type)) (typep object (car type)))
(t (error "~S -- Illegal type specifier to TYPEP." type))))))
(t (error "~S -- Illegal type specifier to TYPEP." type)))))
;;; Similar to Macroexpand, but expands deftypes. If we can't expand it
;;; or it is a bad thing to be a type specifier, then the second value is nil.
(defun type-expand (form)
(let ((def (cond ((symbolp form)
(get form 'deftype-expander))
((and (consp form) (symbolp (car form)))
(get (car form) 'deftype-expander))
(t nil))))
(if def
(type-expand (funcall def (if (consp form) form (list form))))
form)))
;;; 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)
(let ((type (type-expand type)) xtyp)
(cond ((and (symbolp type) (get type 'defstruct-description))
(and (structurep object)
(setq xtyp (svref object 0))
(or (eq xtyp type) (include-chase xtyp type))))
(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 ((eltype (type-expand eltype))
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 (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 simple-array-p (object)
"Returns T if the object is a simple array, else returns NIL."
(and (arrayp object) (not (slisp-array-p object))))
(defun complexp (object)
"Returns T if the object is a complex number, else returns NIL."
(declare (ignore object))
nil)
;;; The following are not defined at user level, but are necessary for
;;; internal use by TYPEP.
;;; Some silly internal things for tenser array hacking:
;;;; Equality Predicates.
(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 (header-ref x %array-fill-pointer-slot))
(data-vector-x (header-ref x %array-data-slot))
(data-vector-y (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)))