(FILECREATED " 1-Sep-85 21:00:34" {ERIS}<LISPCORE>LIBRARY>CMLPRED.;3 15850
changes to: (FNS SIMPLE-STRING-P)
previous date: "31-Aug-85 19:28:35" {ERIS}<LISPCORE>LIBRARY>CMLPRED.;2)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLPREDCOMS)
(RPAQQ CMLPREDCOMS ((VARS TYPE-PRED-ALIST)
(FNS TYPE-OF DESCRIBE-G-VECTOR I-VECTOR-ELEMENT-TYPE DESCRIBE-I-VECTOR DESCRIBE-ARRAY TYPEP
STRUCTURE-TYPEP VECTOR-ELTYPE TEST-LENGTH ARRAY-TYPEP TEST-LIMITS COMMONP BIT-VECTOR-P
RATIONALP COMPLEXP CHARACTERP SIMPLE-STRING-P VECTORP SIMPLE-ARRAY-P SIMPLE-VECTOR-P
SIMPLE-BIT-VECTOR-P CL:ARRAYP FUNCTIONP SEQUENCEP STRUCTUREP INSTANCEP BIGNUMP BITP
RATIOP SLISP-B-VECTOR-P SLISP-VECTOR-P SLISP-ARRAY-P EQL EQUALP)
(P (MOVD (QUOTE NLISTP)
(QUOTE CL:ATOM))
(MOVD (QUOTE CCODEP)
(QUOTE COMPILED-FUNCTION-P))
(MOVD (QUOTE NILL)
(QUOTE LONG-FLOATP))
(MOVD (QUOTE FLOATP)
(QUOTE SHORT-FLOATP))
(MOVD (QUOTE LITATOM)
(QUOTE SYMBOLP)))))
(RPAQQ TYPE-PRED-ALIST ((COMMON . COMMONP)
(NULL . NULL)
(CONS . CONSP)
(LIST . LISTP)
(SYMBOL . SYMBOLP)
(ARRAY . CL: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)
(INSTANCE . INSTANCEP)
(COMPLEX . COMPLEXP)
(SINGLE-FLOAT . SINGLE-FLOATP)
(BIGNUM . BIGNUMP)
(DOUBLE-FLOAT . DOUBLE-FLOATP)
(BIT . BITP)
(LONG-FLOAT . LONG-FLOATP)
(STRUCTURE . STRUCTUREP)
(CL:ATOM . CL:ATOM)))
(DEFINEQ
(TYPE-OF
(CL:LAMBDA (OBJECT) (* kbr: "31-Aug-85 19:08")
(CASE (TYPENAME OBJECT)
(RANDOM (QUOTE RANDOM))
(BIT-VECTOR (BQUOTE (SIMPLE-BIT-VECTOR (\, (\PRIMITIVE VECTOR-LENGTH OBJECT)))))
(I-VECTOR (DESCRIBE-I-VECTOR OBJECT))
(STRINGP (BQUOTE (SIMPLE-STRING (\, (NCHARS OBJECT)))))
(BIGNUM (QUOTE BIGNUM))
(LONG-FLOAT (QUOTE LONG-FLOAT))
(COMPLEX (QUOTE COMPLEX))
(RATIO (QUOTE RATIO))
(G-VECTOR (DESCRIBE-G-VECTOR OBJECT))
(CCODEP (QUOTE COMPILED-FUNCTION))
(CMLARRAYP (DESCRIBE-ARRAY OBJECT))
(LITATOM (QUOTE SYMBOL))
(LISTP (QUOTE CONS)) (* " This is inline, folks."
*)
((SMALLP FIXP)
(QUOTE FIXNUM))
(FLOATP (QUOTE SHORT-FLOAT))
(CHARACTER (QUOTE CHARACTER))
(T (TYPENAME OBJECT)))))
(DESCRIBE-G-VECTOR
(CL:LAMBDA (OBJECT)
(COND
((STRUCTUREP OBJECT)
(SVREF OBJECT 0))
(T (BQUOTE (SIMPLE-VECTOR (\, (\PRIMITIVE VECTOR-LENGTH OBJECT))))))))
(I-VECTOR-ELEMENT-TYPE
(CL:LAMBDA (OBJECT)
(LET ((AC (\PRIMITIVE GET-VECTOR-ACCESS-CODE OBJECT)))
(COND
((< 0 AC 5)
(SVREF (QUOTE (FUNCTION (MOD 2)))
(MOD 4)
(MOD 16)
(MOD 256)
(MOD 65536)))
(T AC))
(CL:ERROR "Invalid I-Vector access code: ~S" AC))))
(DESCRIBE-I-VECTOR
(CL:LAMBDA (OBJECT)
(BQUOTE (SIMPLE-ARRAY (\, (I-VECTOR-ELEMENT-TYPE OBJECT))
(\, (\PRIMITIVE VECTOR-LENGTH OBJECT))))))
(DESCRIBE-ARRAY
(CL:LAMBDA (OBJECT)
(LET ((DATA-VECTOR (\PRIMITIVE HEADER-REF OBJECT \ARRAY-DATA-SLOT))
(RANK (- (\PRIMITIVE HEADER-LENGTH OBJECT)
\ARRAY-FIRST-DIM-SLOT))
(CL:LENGTH (\PRIMITIVE HEADER-REF OBJECT \ARRAY-LENGTH-SLOT)))
(COND
((= RANK 1)
(TYPECASE DATA-VECTOR (SIMPLE-BIT-VECTOR (BQUOTE (BIT-VECTOR (\, CL:LENGTH))))
(SIMPLE-STRING (BQUOTE (STRING (\, CL:LENGTH))))
(SIMPLE-VECTOR (BQUOTE (VECTOR T (\, CL:LENGTH))))
(T (BQUOTE (VECTOR (\, (I-VECTOR-ELEMENT-TYPE DATA-VECTOR))
(\, CL:LENGTH))))))
(T (BQUOTE (ARRAY (\, (TYPECASE DATA-VECTOR (SIMPLE-BIT-VECTOR (QUOTE (MOD 2)))
(SIMPLE-STRING (QUOTE STRING-CHAR))
(SIMPLE-VECTOR (QUOTE T))
(T (I-VECTOR-ELEMENT-TYPE DATA-VECTOR))))
(\, (ARRAY-DIMENSIONS OBJECT)))))))))
(TYPEP
(CL:LAMBDA (OBJECT TYPE)
"Returns T if OBJECT is of the specified TYPE, otherwise NIL."
(LET (TEMP)
(COND
((SYMBOLP TYPE)
(COND
((EQ TYPE (QUOTE T))
T)
((EQ TYPE (QUOTE 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)
(TEST-LENGTH OBJECT (CADR 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))
(CL:MEMBER (CL:MEMBER OBJECT (CDR TYPE)))
(NOT (NOT (TYPEP OBJECT (CADR TYPE))))
(OR (DOLIST (X (CDR TYPE)
NIL)
(COND
((TYPEP OBJECT X)
(RETURN T))
(T NIL))))
(AND (DOLIST (X (CDR TYPE)
T)
(COND
((NOT (TYPEP OBJECT X))
(RETURN NIL))
(T 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 (QUOTE CL:*))
(> N (INTEGER-LENGTH OBJECT))))))
(UNSIGNED-BYTE (AND (INTEGERP OBJECT)
(NOT (MINUSP OBJECT))
(LET ((N (CADR TYPE)))
(OR (NOT N)
(EQ N (QUOTE CL:*))
(>= N (INTEGER-LENGTH OBJECT))))))
(COMPLEX (AND (NUMBERP OBJECT)
(OR (NOT (CDR TYPE))
(TYPEP (REALPART OBJECT)
(CADR TYPE)))))
(T (COND
((INSTANCEP OBJECT)
(SYSTEM::INSTANCE-TYPEP OBJECT TYPE))
(T (CL:ERROR "~S -- Illegal type specifier to TYPEP." TYPE))))))
(T (CL:ERROR "~S -- Illegal type specifier to TYPEP." TYPE))))))
(STRUCTURE-TYPEP
(CL:LAMBDA (OBJECT TYPE)
(LET (DEFSTRUCT)
(COND
((INSTANCEP OBJECT)
(SYSTEM::INSTANCE-TYPEP OBJECT TYPE))
((SETQ DEFSTRUCT (GET TYPE (QUOTE \STRUCTURE-DEFINITION)))
(AND (STRUCTUREP OBJECT)
(OR (EQ (SVREF OBJECT 0)
TYPE)
(MEMQ (SVREF OBJECT 0)
(DD-INCLUDED-BY DEFSTRUCT)))))
(T (CL:ERROR "~S is an unknown type specifier." TYPE))))))
(VECTOR-ELTYPE
(CL:LAMBDA (OBJECT ELTYPE)
(LET ((DATA (COND
((SLISP-ARRAY-P OBJECT)
(\PRIMITIVE HEADER-REF OBJECT \ARRAY-DATA-SLOT))
(T OBJECT))))
(CASE ELTYPE ((T)
(SIMPLE-VECTOR-P DATA))
(STRING-CHAR (SIMPLE-STRING-P DATA))
(BIT (SIMPLE-BIT-VECTOR-P DATA))
((CL:* NIL)
T)
(T (SUBTYPEP ELTYPE (I-VECTOR-ELEMENT-TYPE OBJECT)))))))
(TEST-LENGTH
(CL:LAMBDA (OBJECT CL:LENGTH)
(OR (NULL CL:LENGTH)
(EQ CL:LENGTH (QUOTE CL:*))
(= CL:LENGTH (CL:LENGTH OBJECT)))))
(ARRAY-TYPEP
(CL:LAMBDA (OBJECT TYPE)
(AND (CL:ARRAYP OBJECT)
(VECTOR-ELTYPE OBJECT (CADR TYPE))
(COND
((CDDR TYPE)
(LET ((DIMS (THIRD TYPE)))
(COND
((EQ DIMS (QUOTE CL:*))
T)
((NUMBERP DIMS)
(AND (VECTORP OBJECT)
(= (CL:LENGTH (THE VECTOR OBJECT))
DIMS)))
(T (DOTIMES (I (ARRAY-RANK OBJECT)
(NULL DIMS))
(COND
((NULL DIMS)
(RETURN NIL)))
(LET ((DIM (POP DIMS)))
(COND
((NOT (OR (EQ DIM (QUOTE CL:*))
(= DIM (ARRAY-DIMENSION OBJECT I))))
(RETURN NIL)))))))))
(T T)))))
(TEST-LIMITS
(CL:LAMBDA (OBJECT TYPE)
(LET ((LOW (CADR TYPE))
(HIGH (CADDR TYPE)))
(AND (COND
((NULL LOW)
T)
((EQ LOW (QUOTE CL:*))
T)
((NUMBERP LOW)
(>= OBJECT LOW))
((AND (CONSP LOW)
(NUMBERP (CAR LOW)))
(> OBJECT (CAR LOW)))
(T NIL))
(COND
((NULL HIGH)
T)
((EQ HIGH (QUOTE CL:*))
T)
((NUMBERP HIGH)
(>= OBJECT HIGH))
((AND (CONSP HIGH)
(NUMBERP (CAR HIGH)))
(> OBJECT (CAR HIGH)))
(T NIL))))))
(COMMONP
(CL:LAMBDA (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)))
(COND
((LISTP TYPE-SPEC)
(SETQ TYPE-SPEC (CAR TYPE-SPEC)))
(T NIL))
(MEMQ TYPE-SPEC
(QUOTE (CHARACTER FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT VECTOR
STRING SIMPLE-VECTOR SIMPLE-STRING BIGNUM RATIO COMPLEX
COMPILED-FUNCTION ARRAY SYMBOL CONS)))))))
(BIT-VECTOR-P
(CL:LAMBDA (OBJECT)
"Returns T if the object is a bit vector, else returns NIL."
(BIT-VECTOR-P OBJECT)))
(RATIONALP
(CL:LAMBDA (OBJECT)
"Returns T if the object is an integer or a ratio, else returns NIL."
(RATIONALP OBJECT)))
(COMPLEXP
(CL:LAMBDA (OBJECT)
"Returns T if the object is a complex number, else returns NIL."
(COMPLEXP OBJECT)))
(CHARACTERP
(CL:LAMBDA (OBJECT)
"Returns T if the object is a character, else returns NIL."
(CHARACTERP OBJECT)))
(SIMPLE-STRING-P
(CL:LAMBDA (STRING)
(type? STRINGP STRING)))
(VECTORP
(CL:LAMBDA (OBJECT)
"Returns T if the object is any kind of vector, else returns NIL."
(VECTORP OBJECT)))
(SIMPLE-ARRAY-P
(CL:LAMBDA (OBJECT)
"Returns T if the object is a simple array, else returns NIL."
(AND (CL:ARRAYP OBJECT)
(NOT (SLISP-ARRAY-P OBJECT)))))
(SIMPLE-VECTOR-P
(CL:LAMBDA (OBJECT)
"Returns T if the object is a simple vector, else returns NIL."
(SIMPLE-VECTOR-P OBJECT)))
(SIMPLE-BIT-VECTOR-P
(CL:LAMBDA (OBJECT)
"Returns T if the object is a simple bit vector, else returns NIL."
(SIMPLE-BIT-VECTOR-P OBJECT)))
(CL:ARRAYP
(CL:LAMBDA (OBJECT)
"Returns T if the argument is any kind of array, else returns NIL."
(CL:ARRAYP OBJECT)))
(FUNCTIONP
(CL:LAMBDA (OBJECT)
"Returns T if the object is a function, suitable for use by FUNCALL
or APPLY, else returns NIL."
(FUNCTIONP OBJECT)))
(SEQUENCEP
(CL:LAMBDA (OBJECT)
"Returns T if object is a sequence, NIL otherwise."
(SEQUENCEP OBJECT)))
(STRUCTUREP
(CL:LAMBDA (OBJECT)
(STRUCTUREP OBJECT)))
(INSTANCEP
(CL:LAMBDA (OBJECT)
(= (\PRIMITIVE GET-TYPE OBJECT)
13)))
(BIGNUMP
(CL:LAMBDA (OBJECT) (* kbr: "31-Aug-85 19:27")
(EQ (TYPENAME OBJECT)
(QUOTE BIGNUM))))
(BITP
(CL:LAMBDA (OBJECT)
(BITP OBJECT)))
(RATIOP
(CL:LAMBDA (OBJECT)
(RATIOP OBJECT)))
(SLISP-B-VECTOR-P
(CL:LAMBDA (OBJECT)
(SLISP-B-VECTOR-P OBJECT)))
(SLISP-VECTOR-P
(CL:LAMBDA (OBJECT)
(SLISP-VECTOR-P OBJECT)))
(SLISP-ARRAY-P
(CL:LAMBDA (OBJECT)
(SLISP-ARRAY-P OBJECT)))
(EQL
(CL:LAMBDA (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)))
(EQUALP
(CL:LAMBDA (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 ((CL:LENGTH (CL:LENGTH X)))
(AND (VECTORP Y)
(= CL:LENGTH (CL:LENGTH Y))
(DOTIMES (I CL:LENGTH T)
(LET ((X-EL (AREF X I))
(Y-EL (AREF Y I)))
(COND
((NOT (OR (EQL X-EL Y-EL)
(EQUALP X-EL Y-EL)))
(RETURN NIL))))))))
((CL:ARRAYP X)
(LET ((RANK (ARRAY-RANK X))
(LEN (\PRIMITIVE HEADER-REF X \ARRAY-LENGTH-SLOT)))
(AND (CL:ARRAYP Y)
(= (ARRAY-RANK Y)
RANK)
(DOTIMES (I RANK T)
(COND
((NOT (= (ARRAY-DIMENSION X I)
(ARRAY-DIMENSION Y I)))
(RETURN NIL))))
(LET ((X-VEC (\PRIMITIVE HEADER-REF X \ARRAY-DATA-SLOT))
(Y-VEC (\PRIMITIVE HEADER-REF Y \ARRAY-DATA-SLOT)))
(CL:DO ((I (\PRIMITIVE HEADER-REF X \ARRAY-DISPLACEMENT-SLOT)
(1+ I))
(J (\PRIMITIVE HEADER-REF Y \ARRAY-DISPLACEMENT-SLOT)
(1+ J))
(CL:COUNT LEN (1- CL:COUNT)))
((ZEROP CL:COUNT)
T)
(LET ((X-EL (AREF X-VEC I))
(Y-EL (AREF Y-VEC J)))
(COND
((NOT (OR (EQL X-EL Y-EL)
(EQUALP X-EL Y-EL)))
(RETURN NIL)))))))))
(T NIL))))
)
(MOVD (QUOTE NLISTP)
(QUOTE CL:ATOM))
(MOVD (QUOTE CCODEP)
(QUOTE COMPILED-FUNCTION-P))
(MOVD (QUOTE NILL)
(QUOTE LONG-FLOATP))
(MOVD (QUOTE FLOATP)
(QUOTE SHORT-FLOATP))
(MOVD (QUOTE LITATOM)
(QUOTE SYMBOLP))
(PUTPROPS CMLPRED COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2014 15532 (TYPE-OF 2024 . 2970) (DESCRIBE-G-VECTOR 2972 . 3161) (I-VECTOR-ELEMENT-TYPE
3163 . 3499) (DESCRIBE-I-VECTOR 3501 . 3663) (DESCRIBE-ARRAY 3665 . 4571) (TYPEP 4573 . 7994) (
STRUCTURE-TYPEP 7996 . 8457) (VECTOR-ELTYPE 8459 . 8886) (TEST-LENGTH 8888 . 9051) (ARRAY-TYPEP 9053
. 9791) (TEST-LIMITS 9793 . 10398) (COMMONP 10400 . 10993) (BIT-VECTOR-P 10995 . 11131) (RATIONALP
11133 . 11272) (COMPLEXP 11274 . 11406) (CHARACTERP 11408 . 11539) (SIMPLE-STRING-P 11541 . 11616) (
VECTORP 11618 . 11750) (SIMPLE-ARRAY-P 11752 . 11938) (SIMPLE-VECTOR-P 11940 . 12085) (
SIMPLE-BIT-VECTOR-P 12087 . 12244) (CL:ARRAYP 12246 . 12383) (FUNCTIONP 12385 . 12554) (SEQUENCEP
12556 . 12677) (STRUCTUREP 12679 . 12746) (INSTANCEP 12748 . 12837) (BIGNUMP 12839 . 13000) (BITP
13002 . 13057) (RATIOP 13059 . 13118) (SLISP-B-VECTOR-P 13120 . 13199) (SLISP-VECTOR-P 13201 . 13276)
(SLISP-ARRAY-P 13278 . 13351) (EQL 13353 . 13566) (EQUALP 13568 . 15530)))))
STOP