github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-25 20:06:44 +00:00
Code Issues Projects Releases Wiki Activity

add merge in Ron's 11/21/2020 lispcore

Browse Source
This commit is contained in:
Larry Masinter
2020-11-21 13:24:44 -08:00
parent e9a80b1144
commit ce4eae736e
794 changed files with 117194 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

376
CLTL2/CMLTYPES Normal file
View File

@@ -0,0 +1,376 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
(IL:FILECREATED " 8-Feb-93 16:55:40" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLTYPES.;9| 46967
IL:|changes| IL:|to:| (IL:TYPES ARRAY SIMPLE-ARRAY)
IL:|previous| IL:|date:| " 1-Apr-92 12:17:57"
IL:|{DSK}<usr>local>lde>lispcore>sources>CMLTYPES.;8|)
; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:CMLTYPESCOMS)
(IL:RPAQQ IL:CMLTYPESCOMS ((IL:* IL:|;;;| "Implementation of Common Lisp type system. ") (IL:* IL:|;;;| "implementation by Greg Nuyens ,Larry Masinter and Jan Pedersen.") (IL:* IL:|;;;| "Predicates") (IL:FUNCTIONS COMMONP) (IL:* IL:|;;;| "Typep and friends") (IL:VARIABLES *TYPEP-HASH-TABLE*) (IL:FUNCTIONS TYPEP TYPE-OF COERCE TYPECASE) (IL:FUNCTIONS %VALID-TYPE-P) (XCL:OPTIMIZERS TYPEP COERCE) (IL:* IL:|;;;| "for DEFTYPE") (IL:DEFINE-TYPES IL:TYPES) (IL:FUNCTIONS DEFTYPE TYPE-EXPAND TYPE-EXPANDER SETF-TYPE-EXPANDER) (IL:SETFS TYPE-EXPANDER) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:* IL:|;;| "There is still code out there that calls the IL: versions") (IL:P (IL:MOVD (QUOTE TYPE-EXPAND) (QUOTE IL:TYPE-EXPAND)) (IL:MOVD (QUOTE TYPE-EXPANDER) (QUOTE IL:TYPE-EXPANDER)))) (IL:* IL:|;;;| "Support functions") (IL:FUNCTIONS ARRAY-TYPE SYMBOL-TYPE XCL:FALSE XCL:TRUE %RANGE-TYPE) (IL:FUNCTIONS NUMBERP FLOATP CL:REALP) (XCL:OPTIMIZERS NUMBERP FLOATP CL:REALP XCL:FALSE XCL:TRUE) (IL:* IL:|;;;| "For TYPEP") (IL:FUNCTIONS %TYPEP-PRED BIGNUMP) (IL:* IL:|;;;| "for SUBTYPEP ") (IL:VARIABLES %NO-SUPER-TYPE *COMMON-LISP-BASE-TYPES* *BASE-TYPE-LATTICE*) (IL:FUNCTIONS SUBTYPEP SUBTYPEP-TYPE-EXPAND SI::DATATYPE-P SI::SUB-DATATYPE-P EQUAL-DIMENSIONS COMPLETE-ARRAY-TYPE-DIMENSIONS COMPLETE-META-EXPRESSION-DEFAULTS RANGE<= BASE-SUBTYPEP EQUAL-ELEMENT-TYPE USEFUL-TYPE-EXPANSION-P) (IL:* IL:|;;;| "Basic deftypes") (IL:TYPES ATOM BIGNUM BIT CHARACTER CONS DOUBLE-FLOAT EQL FIXNUM STREAM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT MEMBER MOD NULL NUMBER PACKAGE CL:REAL SHORT-FLOAT SIGNED-BYTE STANDARD-CHAR STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER SINGLE-FLOAT SYMBOL UNSIGNED-BYTE RATIONAL READTABLE COMMON COMPILED-FUNCTION SEQUENCE) (IL:* IL:|;;;| "Array Types") (IL:TYPES ARRAY VECTOR STRING SIMPLE-STRING SIMPLE-ARRAY SIMPLE-VECTOR BIT-VECTOR SIMPLE-BIT-VECTOR CL:BASE-STRING CL:SIMPLE-BASE-STRING) (IL:* IL:|;;;| "Stream types required by CLtL2") (IL:TYPES CL:BROADCAST-STREAM CL:CONCATENATED-STREAM CL:ECHO-STREAM CL:SYNONYM-STREAM CL:STRING-STREAM CL:FILE-STREAM CL:TWO-WAY-STREAM) (IL:* IL:|;;;| "Fast predicates for typep") (IL:DEFINE-TYPES TYPEP) (IL:FUNCTIONS DEFTYPEP) (TYPEP LIST SEQUENCE MEMBER ARRAY SIMPLE-ARRAY VECTOR SIMPLE-VECTOR COMPLEX INTEGER MOD SIGNED-BYTE UNSIGNED-BYTE RATIONAL FLOAT STRING SIMPLE-STRING BIT-VECTOR SIMPLE-BIT-VECTOR EQL CL:REAL) (IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names") (IL:PROP CMLTYPE IL:CHARACTER IL:FIXP IL:FLOATP IL:GENERAL-ARRAY IL:LISTP IL:LITATOM IL:ONED-ARRAY IL:SMALLP IL:HARRAYP IL:TWOD-ARRAY) (IL:PROP CMLSUBTYPE-DESCRIMINATOR SYMBOL ARRAY) (IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property") (IL:PROP IL:PROPTYPE :TYPE-EXPANDER IL:TYPE-EXPANDER) (IL:* IL:|;;;| "Compiler options") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLTYPES) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T))))
(IL:* IL:|;;;| "Implementation of Common Lisp type system. ")
(IL:* IL:|;;;| "implementation by Greg Nuyens ,Larry Masinter and Jan Pedersen.")
(IL:* IL:|;;;| "Predicates")
(DEFUN COMMONP (OBJECT) (TYPEP OBJECT (QUOTE COMMON)))
(IL:* IL:|;;;| "Typep and friends")
(DEFPARAMETER *TYPEP-HASH-TABLE* (MAKE-HASH-TABLE :TEST (QUOTE EQ)))
(DEFUN TYPEP (OBJECT TYPE) (IL:* IL:|;;| "Check if OBJECT is of type TYPE") (LET* ((SYMBOL-TYPE (IF (CONSP TYPE) (CAR TYPE) TYPE)) (FN (GETHASH SYMBOL-TYPE *TYPEP-HASH-TABLE*))) (IF FN (IF (CONSP TYPE) (FUNCALL FN OBJECT (CDR TYPE)) (FUNCALL FN OBJECT)) (IL:* IL:|;;| "Expand the type") (IF (CONSP TYPE) (CASE SYMBOL-TYPE (SATISFIES (FUNCALL (CADR TYPE) OBJECT)) ((:DATATYPE IL:DATATYPE) (IL:TYPENAMEP OBJECT (CADR TYPE))) (NOT (NOT (TYPEP OBJECT (CADR TYPE)))) (AND (DOLIST (SUB-TYPE (CDR TYPE) T) (IF (NOT (TYPEP OBJECT SUB-TYPE)) (RETURN NIL)))) (OR (DOLIST (SUB-TYPE (CDR TYPE) NIL) (IF (TYPEP OBJECT SUB-TYPE) (RETURN T)))) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER SYMBOL-TYPE))) (IF EXPANDER (TYPEP OBJECT (FUNCALL EXPANDER TYPE)) (ERROR "Unknown type expression: ~s" TYPE))))) (CASE SYMBOL-TYPE ((T) T) ((NIL) NIL) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER SYMBOL-TYPE))) (IF EXPANDER (TYPEP OBJECT (FUNCALL EXPANDER (LIST TYPE))) (ERROR "Unknown type expression: ~s" TYPE)))))))))
(DEFUN TYPE-OF (X) (LET ((TYPENAME (IL:\\INDEXATOMPNAME (IL:|fetch| IL:DTDNAME IL:|of| (IL:\\GETDTD (IL:NTYPX X)))))) (SETQ TYPENAME (OR (GET TYPENAME (QUOTE CMLTYPE)) TYPENAME)) (OR (LET ((D (GET TYPENAME (QUOTE CMLSUBTYPE-DESCRIMINATOR)))) (AND D (FUNCALL D X))) TYPENAME)))
(DEFUN COERCE (OBJECT RESULT-TYPE) (IL:* IL:|;;| "Coerce object to result-type if possible") (IF (TYPEP OBJECT RESULT-TYPE) OBJECT (COND ((EQ RESULT-TYPE (QUOTE CHARACTER)) (CHARACTER OBJECT)) ((MEMBER RESULT-TYPE (QUOTE (FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT)) :TEST (FUNCTION EQ)) (FLOAT OBJECT)) ((EQ (IF (CONSP RESULT-TYPE) (CAR RESULT-TYPE) RESULT-TYPE) (QUOTE COMPLEX)) (IF (CONSP RESULT-TYPE) (LET ((SUBTYPE (CADR RESULT-TYPE))) (IF (COMPLEXP OBJECT) (COMPLEX (COERCE (REALPART OBJECT) SUBTYPE) (COERCE (IMAGPART OBJECT) SUBTYPE)) (COMPLEX (COERCE OBJECT SUBTYPE)))) (COMPLEX OBJECT))) ((TYPEP OBJECT (QUOTE SEQUENCE)) (MAP RESULT-TYPE (QUOTE IDENTITY) OBJECT)) (T (ERROR "Cannot coerce ~S to type: ~S" OBJECT RESULT-TYPE)))))
(DEFMACRO TYPECASE (KEYFORM &REST FORMS) "Type dispatch, order is important, more specific types should appear first" (IL:BQUOTE (LET (($$TYPE-VALUE (IL:\\\, KEYFORM))) (COND (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (FORM) (LET ((PRED (IF (MEMBER (CAR FORM) (QUOTE (OTHERWISE T)) :TEST (FUNCTION EQ)) T (IL:BQUOTE (TYPEP $$TYPE-VALUE (QUOTE (IL:\\\, (CAR FORM))))))) (FORM (IF (NULL (CDR FORM)) (QUOTE (NIL)) (CDR FORM)))) (IL:BQUOTE ((IL:\\\, PRED) (IL:\\\,@ FORM)))))) FORMS))))))
(DEFUN %VALID-TYPE-P (TYPE) (IF (CONSP TYPE) (CASE (CAR TYPE) (SATISFIES T) ((OR AND) (EVERY (QUOTE %VALID-TYPE-P) (CDR TYPE))) (NOT (%VALID-TYPE-P (CADR TYPE))) ((:DATATYPE IL:DATATYPE) T) (OTHERWISE (AND (TYPE-EXPANDER TYPE) T))) (OR (AND (TYPE-EXPANDER TYPE) T) (EQ TYPE T) (NULL TYPE))))
(XCL:DEFOPTIMIZER TYPEP (OBJ TYPE) (IF (CONSTANTP TYPE) (LET ((TYPE-EXPR (EVAL TYPE))) (IF (%VALID-TYPE-P TYPE-EXPR) (IL:BQUOTE ((IL:\\\, (%TYPEP-PRED TYPE-EXPR)) (IL:\\\, OBJ))) (PROGN (WARN "Can't optimize (typep ~s ~s); type not known." OBJ TYPE) (QUOTE COMPILER:PASS)))) (QUOTE COMPILER:PASS)))
(XCL:DEFOPTIMIZER COERCE (OBJECT RESULT-TYPE) (IL:* IL:|;;| "Open code the simple coerce cases ") (IF (CONSTANTP RESULT-TYPE) (CASE (EVAL RESULT-TYPE) (CHARACTER (IL:BQUOTE (CHARACTER (IL:\\\, OBJECT)))) ((FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) (IL:BQUOTE (FLOAT (IL:\\\, OBJECT)))) (OTHERWISE (QUOTE COMPILER:PASS))) (QUOTE COMPILER:PASS)))
(IL:* IL:|;;;| "for DEFTYPE")
(XCL:DEF-DEFINE-TYPE IL:TYPES "Common Lisp type definitions")
(XCL:DEFDEFINER (DEFTYPE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFTYPE (IL:\\\, NAME) ("Arg list") "Body")))))) IL:TYPES (NAME DEFTYPE-ARGS &BODY BODY) (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPE: ~S" NAME)) (LET ((EXPANDER-NAME (XCL:PACK (LIST "type-expand-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOCSTRING) (IL:PARSE-DEFMACRO DEFTYPE-ARGS (QUOTE SI::%$$TYPE-FORM) BODY NAME NIL :DEFAULT-DEFAULT (QUOTE (QUOTE *))) (IL:BQUOTE (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (LAMBDA (SI::%$$TYPE-FORM) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY))))) (SETF (TYPE-EXPANDER (QUOTE (IL:\\\, NAME))) (QUOTE (IL:\\\, EXPANDER-NAME))) (IL:\\\,@ (AND DOCSTRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE TYPE)) (IL:\\\, DOCSTRING)))))) (IL:\\\,@ (IF (NULL DEFTYPE-ARGS) (LET ((TYPEP-NAME (XCL:PACK (LIST "typep-evaluate-" NAME) (SYMBOL-PACKAGE NAME)))) (IL:BQUOTE ((EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPEP-NAME))) (FUNCTION (LAMBDA (SI::%$$OBJECT) (TYPEP SI::%$$OBJECT (QUOTE (IL:\\\, NAME)))))) (PUTHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE* (QUOTE (IL:\\\, TYPEP-NAME)))) (EVAL-WHEN (EVAL) (PUTHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE* NIL))))))))))))
(DEFUN TYPE-EXPAND (FORM &OPTIONAL (EXPANDER (TYPE-EXPANDER FORM))) (IL:* IL:|;;| "Expands a type form according to deftypes in effect. The caller must ensure there is an expander for the form ") (IF EXPANDER (VALUES (FUNCALL EXPANDER (ETYPECASE FORM (SYMBOL (LIST FORM)) (CONS FORM))) T) (VALUES FORM NIL)))
(DEFUN TYPE-EXPANDER (TYPE) (LET* ((SYMBOL-TYPE (ETYPECASE TYPE (SYMBOL TYPE) (CONS (CAR TYPE)))) (EXPANDER (OR (GET SYMBOL-TYPE (QUOTE :TYPE-EXPANDER)) (GET SYMBOL-TYPE (QUOTE IL:TYPE-EXPANDER))))) (IF (AND (NULL EXPANDER) (SYMBOLP TYPE) (SI::DATATYPE-P TYPE)) (IL:* IL:|;;| "Install a deftype") (LET ((DEFTYPE-FORM (IL:BQUOTE (DEFTYPE (IL:\\\, TYPE) NIL (QUOTE (:DATATYPE (IL:\\\, TYPE))))))) (IF (FBOUNDP (QUOTE XCL:COMPILE-FORM)) (IL:* IL:|;;| "Compile form on the fly") (XCL:COMPILE-FORM DEFTYPE-FORM) (LET ((IL:DFNFLG NIL) (IL:FILEPKGFLG NIL) (IL:* IL:|;;| "DFNFLG nil makes sure this has an effect and filepkgflg nil makes sure it isn't remembered.")) (EVAL DEFTYPE-FORM))) (TYPE-EXPANDER TYPE)) EXPANDER)))
(DEFMACRO SETF-TYPE-EXPANDER (SYMBOL EXPANDER) (IL:BQUOTE (SETF (GET (IL:\\\, SYMBOL) (QUOTE :TYPE-EXPANDER)) (IL:\\\, EXPANDER))))
(DEFSETF TYPE-EXPANDER SETF-TYPE-EXPANDER)
(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD
(IL:MOVD (QUOTE TYPE-EXPAND) (QUOTE IL:TYPE-EXPAND))
(IL:MOVD (QUOTE TYPE-EXPANDER) (QUOTE IL:TYPE-EXPANDER))
)
(IL:* IL:|;;;| "Support functions")
(DEFUN ARRAY-TYPE (ARRAY) (LET ((RANK (ARRAY-RANK ARRAY))) (IF (XCL:SIMPLE-ARRAY-P ARRAY) (IF (EQ 1 RANK) (LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY))) (COND ((SIMPLE-STRING-P ARRAY) (LIST (QUOTE SIMPLE-STRING) SIZE)) ((SIMPLE-BIT-VECTOR-P ARRAY) (LIST (QUOTE SIMPLE-BIT-VECTOR) SIZE)) (T (LET ((ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY))) (IF (EQ ELT-TYPE T) (LIST (QUOTE SIMPLE-VECTOR) SIZE) (LIST (QUOTE SIMPLE-ARRAY) ELT-TYPE (LIST SIZE))))))) (LIST (QUOTE SIMPLE-ARRAY) (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY))) (IF (EQ 1 RANK) (LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY))) (COND ((STRINGP ARRAY) (LIST (QUOTE STRING) SIZE)) ((BIT-VECTOR-P ARRAY) (LIST (QUOTE BIT-VECTOR) SIZE)) (T (LIST (QUOTE VECTOR) (ARRAY-ELEMENT-TYPE ARRAY) SIZE)))) (LIST (QUOTE ARRAY) (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY))))))
(DEFUN SYMBOL-TYPE (SYMBOL) (IF (KEYWORDP SYMBOL) (QUOTE KEYWORD) (QUOTE SYMBOL)))
(DEFUN XCL:FALSE NIL NIL)
(DEFUN XCL:TRUE NIL T)
(DEFUN %RANGE-TYPE (BASE-TYPE LOW HIGH RANGE-LIST) (IL:* IL:|;;| "Returns a type form discriminating basetype. Rangelist is a list of (decreasing) subranges of the full range of basetype (represented as a list of low, high and subtype). If low and high fall within its range, a form is returned which discriminates on the subtype, and checks the range. If low and high are exactly the range of the subtype then no range checking form is returned.") (COND ((AND (EQ LOW (QUOTE *)) (EQ HIGH (QUOTE *))) BASE-TYPE) ((OR (EQ LOW (QUOTE *)) (EQ HIGH (QUOTE *))) (IL:BQUOTE (AND (IL:\\\, BASE-TYPE) (SATISFIES (LAMBDA (X) (IL:\\\,@ (IF (NOT (EQ LOW (QUOTE *))) (IL:BQUOTE (((IL:\\\, (COND ((CONSP LOW) (SETQ LOW (CAR LOW)) (QUOTE <)) (T (QUOTE <=)))) (IL:\\\, LOW) X))))) (IL:\\\,@ (IF (NOT (EQ HIGH (QUOTE *))) (IL:BQUOTE (((IL:\\\, (COND ((CONSP HIGH) (SETQ HIGH (CAR HIGH)) (QUOTE <)) (T (QUOTE <=)))) X (IL:\\\, HIGH))))))))))) (T (DOLIST (X RANGE-LIST (IL:BQUOTE (AND (IL:\\\, BASE-TYPE) (SATISFIES (LAMBDA (X) (AND ((IL:\\\, (COND ((CONSP LOW) (SETQ LOW (CAR LOW)) (QUOTE <)) (T (QUOTE <=)))) (IL:\\\, LOW) X) ((IL:\\\, (COND ((CONSP HIGH) (SETQ HIGH (CAR HIGH)) (QUOTE <)) (T (QUOTE <=)))) X (IL:\\\, HIGH)))))))) (IL:* IL:|;;| "If the limits are exactly the range specified in the rangelist, then return the corresponding type (since no range-check will be required in the result).") (IF (AND (EQUAL LOW (CAR X)) (EQUAL HIGH (CADR X))) (RETURN (CADDR X))) (IL:* IL:|;;| "If the limits are within the range, then remember the basetype.") (IF (<= (CAR X) (IF (CONSP LOW) (1+ (CAR LOW)) LOW) (IF (CONSP HIGH) (1- (CAR HIGH)) HIGH) (CADR X)) (SETQ BASE-TYPE (CADDR X)))))))
(DEFUN NUMBERP (X) (AND (IL:NUMBERP X) T))
(DEFUN FLOATP (X) (AND (IL:FLOATP X) T))
(DEFUN CL:REALP (CL::X) (TYPEP CL::X (QUOTE CL:REAL)))
(XCL:DEFOPTIMIZER NUMBERP (X) (IL:BQUOTE (AND (IL:NUMBERP (IL:\\\, X)) T)))
(XCL:DEFOPTIMIZER FLOATP (X) (IL:BQUOTE (AND (IL:FLOATP (IL:\\\, X)) T)))
(XCL:DEFOPTIMIZER CL:REALP (CL::X) (IL:BQUOTE (TYPEP (IL:\\\, CL::X) (QUOTE CL:REAL))))
(XCL:DEFOPTIMIZER XCL:FALSE (&BODY IL:FORMS) (IL:BQUOTE (PROG1 NIL (IL:\\\,@ IL:FORMS))))
(XCL:DEFOPTIMIZER XCL:TRUE (&BODY XCL::FORMS) (IL:BQUOTE (PROG1 T (IL:\\\,@ XCL::FORMS))))
(IL:* IL:|;;;| "For TYPEP")
(DEFUN %TYPEP-PRED (TYPE) (IL:* IL:|;;| "returns the predicate of one argument that determines this type.") (COND ((CONSP TYPE) (CASE (CAR TYPE) (SATISFIES (CADR TYPE)) ((:DATATYPE IL:DATATYPE) (IL:BQUOTE (LAMBDA (SI::%$$OBJECT) (IL:TYPENAMEP SI::%$$OBJECT (QUOTE (IL:\\\, (CADR TYPE))))))) ((AND OR NOT) (IL:BQUOTE (LAMBDA (SI::%$$OBJECT) ((IL:\\\, (CAR TYPE)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SUBTYPE) (LIST (%TYPEP-PRED SUBTYPE) (QUOTE SI::%$$OBJECT)))) (CDR TYPE))))))) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER (CAR TYPE)))) (IF EXPANDER (%TYPEP-PRED (FUNCALL EXPANDER TYPE)) (CERROR "Look again for a deftype on ~S." "No type definition for ~S. Specify one with DEFTYPE." TYPE)))))) (T (COND ((EQ TYPE T) (QUOTE XCL:TRUE)) ((EQ TYPE NIL) (QUOTE XCL:FALSE)) (T (LET ((EXPANDER (TYPE-EXPANDER TYPE))) (COND (EXPANDER (%TYPEP-PRED (FUNCALL EXPANDER (LIST TYPE)))) (T (IL:* IL:|;;| "there is no deftype on this non-list type. ") (LOOP (IF (TYPE-EXPANDER TYPE) (RETURN NIL)) (CERROR "Use the deftype you have specified." "No type definition for ~S. Specify one with DEFTYPE." TYPE)) (%TYPEP-PRED TYPE)))))))))
(DEFUN BIGNUMP (X) (OR (IL:TYPENAMEP X (QUOTE IL:FIXP)) (IL:TYPENAMEP X (QUOTE BIGNUM))))
(IL:* IL:|;;;| "for SUBTYPEP ")
(DEFCONSTANT %NO-SUPER-TYPE 0 "the value in the dtdsupertype field which indicates no super type.")
(DEFCONSTANT *COMMON-LISP-BASE-TYPES* (IL:* IL:|;;| "The types which are known to be disjoint from any type explicitly handled by subtypep.") (QUOTE ((IL:* IL:|;;| "The only types that need to be in this list are types on page 43 that expand into a satisfies or datatype clause, i.e. any type that expands into something that base-subtypep doesn't know to handle, e.g. satisfies.") ARRAY ATOM CL:BASE-CHARACTER BIGNUM (IL:* IL:\; "even though bignum expands into a datatype, that datatype is not a subdatatype of integer, etc. so must be explicitly handled.") CHARACTER COMMON COMPLEX COMPILED-FUNCTION CONS IL:DATATYPE (IL:* IL:\; "this is only here for back-compatibility. The first global recompile, this can go.") :DATATYPE CL:EXTENDED-CHARACTER FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO (IL:* IL:\; "same comment for ratio as bignum.") RATIONAL READTABLE SIMPLE-ARRAY STANDARD-CHAR STREAM STRING-CHAR SYMBOL T)))
(DEFCONSTANT *BASE-TYPE-LATTICE* (QUOTE ((NUMBER CL:REAL RATIONAL INTEGER RATIO FIXNUM BIGNUM COMPLEX FLOAT) (CL:REAL RATIONAL INTEGER RATIO FIXNUM BIGNUM FLOAT) (RATIONAL INTEGER RATIO FIXNUM BIGNUM) (INTEGER FIXNUM BIGNUM) (CHARACTER STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER STANDARD-CHAR) (STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER STANDARD-CHAR) (CL:EXTENDED-CHARACTER CL:BASE-CHARACTER STANDARD-CHAR) (CL:BASE-CHARACTER STANDARD-CHAR) (LIST NULL) (SYMBOL KEYWORD NULL) (ARRAY SIMPLE-ARRAY) (FUNCTION COMPILED-FUNCTION) (NIL) (IL:DATATYPE :DATATYPE) (IL:* IL:\; "the presence of il:datatype is for back compatibility.") (:DATATYPE IL:DATATYPE))) "the lattice which tells the (base) subtypes of any base type.")
(DEFUN SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;| "Returns T if type1 is a subtype of type2. If second value is nil, couldn't decide.") (IF (EQUAL TYPE1 TYPE2) (IL:* IL:|;;| "no need to complete any further recursion, so just return success.") (VALUES T T) (CASE (IF (CONSP TYPE1) (CAR TYPE1) TYPE1) (AND (IL:* IL:|;;| "(subtypep '(and t1 t2 ...) 't3) <= (or (subtypep 't1 't3) (subtypep 't2 't3) ... ) because '(and t1 t2 ...) denotes the intersection of types t1, t2, ...") (IL:* IL:|;;| "Even if none of the conjuncts is a subtype, we still can't return (NIL T) because the intersection might still be a subtype.") (LET ((RESULT NIL) CERTAINTY CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE1-CONJUNCT (CDR TYPE1) NIL) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1-CONJUNCT TYPE2)) (WHEN CONJUNCT-RESULT (SETQ RESULT T) (IF CONJUNCT-CERTAINTY (RETURN T))))) (VALUES RESULT CERTAINTY))) (OR (IL:* IL:|;;| "(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)") (LET ((RESULT T) CERTAINTY (LOOP-CERTAINTY T) CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE1-CONJUNCT (CDR TYPE1) LOOP-CERTAINTY) (IL:* IL:|;;| "returns t only if every conjunct clause is a certain subtype, or if one conjunct clause is certainly not a subtype") (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1-CONJUNCT TYPE2)) (COND ((NULL CONJUNCT-RESULT) (SETQ RESULT NIL) (IF CONJUNCT-CERTAINTY (RETURN T) (IL:* IL:|;;| "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) (SETQ LOOP-CERTAINTY NIL)))))) (VALUES RESULT CERTAINTY))) (OTHERWISE (IL:* IL:|;;| "Try to expand type1") (MULTIPLE-VALUE-BIND (NEW-TYPE1 EXPANDED?) (SUBTYPEP-TYPE-EXPAND TYPE1) (IF (USEFUL-TYPE-EXPANSION-P NEW-TYPE1 EXPANDED?) (SUBTYPEP NEW-TYPE1 TYPE2) (IL:* IL:|;;| "We now have a base type for type1, there is nothing further to be done with it, by itself. So we check for special cases in type2") (CASE (IF (CONSP TYPE2) (CAR TYPE2) TYPE2) (AND (IL:* IL:|;;| " (subtypep 't1 '(and t2 t3 ...)) <=> (and (subtypep 't1 't2) (subtypep 't1 't3) ...) because '(and t2 t3 ...) denotes the intersection of types t2, t3, ...") (LET ((RESULT T) CERTAINTY (LOOP-CERTAINTY T) CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE2-CONJUNCT (CDR TYPE2) LOOP-CERTAINTY) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1 TYPE2-CONJUNCT)) (COND ((NULL CONJUNCT-RESULT) (SETQ RESULT NIL) (IF CONJUNCT-CERTAINTY (RETURN T) (IL:* IL:|;;| "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) (SETQ LOOP-CERTAINTY NIL)))))) (VALUES RESULT CERTAINTY))) (OR (IL:* IL:|;;| "(subtypep 't1 '(or t2 t3 ...)) <=> (or (subtypep 't1 't2) (subtypep 't1 't3) ... ) because '(or t1 t2 ...) denotes the union of types t1, t2, ...") (IL:* IL:|;;| "We can't ever return (values nil t) because the t2..tn might form a partition of t1, i.e.") (IL:* IL:|;;| "(deftype evenp nil '(and integer (satisfies %evenp)))") (IL:* IL:|;;| "(deftype oddp nil '(and integer (satisfies %oddp)))") (IL:* IL:|;;| "(subtypep 'integer '(or evenp oddp)) is true, but the satisfies makes it undecidable, so we must return (nil nil).") (LET ((RESULT NIL) CERTAINTY CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE2-CONJUNCT (CDR TYPE2) NIL) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1 TYPE2-CONJUNCT)) (WHEN CONJUNCT-RESULT (SETQ RESULT T) (IF CONJUNCT-CERTAINTY (RETURN T))))) (VALUES RESULT CERTAINTY))) (OTHERWISE (IL:* IL:|;;| "try to expand type2.") (MULTIPLE-VALUE-BIND (NEW-TYPE2 EXPANDED?) (SUBTYPEP-TYPE-EXPAND TYPE2) (IF (USEFUL-TYPE-EXPANSION-P NEW-TYPE2 EXPANDED?) (SUBTYPEP TYPE1 NEW-TYPE2) (IL:* IL:|;;| "we have now handled everything but base types. There is no further expansion etc, to be done.") (BASE-SUBTYPEP TYPE1 TYPE2)))))))))))
(DEFUN SUBTYPEP-TYPE-EXPAND (TYPE) (IL:* IL:|;;| "Like type-expand, except it doesn't expand base-types.") (IF (MEMBER (IF (CONSP TYPE) (CAR TYPE) TYPE) *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)) (VALUES TYPE NIL) (TYPE-EXPAND TYPE)))
(DEFUN SI::DATATYPE-P (SI::NAME) (IL:* IL:|;;| "Returns T if name is a datatype known to the XAIE type system") (AND (IL:\\TYPENUMBERFROMNAME SI::NAME) T))
(DEFUN SI::SUB-DATATYPE-P (TYPE1 TYPE2) (IL:* IL:|;;| "Returns T if type2 is a (not necessarily proper) supertype of type1.") (DO* ((TYPE-NUMBER-1 (IL:\\TYPENUMBERFROMNAME TYPE1)) (TYPE-NUMBER-2 (IL:\\TYPENUMBERFROMNAME TYPE2)) (SUPER-TYPE-NUMBER TYPE-NUMBER-1 (IL:|fetch| IL:DTDSUPERTYPE IL:|of| (IL:\\GETDTD SUPER-TYPE-NUMBER)))) ((EQ %NO-SUPER-TYPE SUPER-TYPE-NUMBER) (IL:* IL:|;;| "we didn't find type2 on type1's super chain so return NIL ") NIL) (IF (EQ SUPER-TYPE-NUMBER TYPE-NUMBER-2) (RETURN T))))
(DEFUN EQUAL-DIMENSIONS (DIMS1 DIMS2) (IL:* IL:|;;| "Says if dims1 and dims2 are the same in each dimension (allowing for wildcard's (*'s)).") (OR (EQ DIMS1 (QUOTE *)) (EQ DIMS2 (QUOTE *)) (AND (EQUAL (LENGTH DIMS1) (LENGTH DIMS2)) (DO ((DIM1 DIMS1 (CDR DIM1)) (DIM2 DIMS2 (CDR DIM2))) ((NULL DIM1) T) (IF (NOT (OR (EQ (CAR DIM1) (QUOTE *)) (EQ (CAR DIM2) (QUOTE *)) (EQ (CAR DIM1) (CAR DIM2)))) (RETURN NIL))))))
(DEFUN COMPLETE-ARRAY-TYPE-DIMENSIONS (DIMENSIONS) (ETYPECASE DIMENSIONS (CONS DIMENSIONS) ((OR NULL (MEMBER *)) (QUOTE *)) (INTEGER (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))))
(DEFUN COMPLETE-META-EXPRESSION-DEFAULTS (TYPE) (IL:* IL:|;;| "given a type expression finishes the defaults the same way as the type-expander.") (LET ((LIST-TYPE (IF (LISTP TYPE) TYPE (LIST TYPE)))) (CASE (CAR LIST-TYPE) ((SIMPLE-ARRAY ARRAY) (CL:DESTRUCTURING-BIND (ARRAY-TYPE &OPTIONAL (ELEMENT-TYPE (QUOTE *)) (DIMENSIONS (QUOTE *))) LIST-TYPE (LIST ARRAY-TYPE ELEMENT-TYPE (COMPLETE-ARRAY-TYPE-DIMENSIONS DIMENSIONS)))) ((INTEGER FLOAT RATIONAL) (CL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (LOWER (QUOTE *)) (HIGHER (QUOTE *))) LIST-TYPE (LIST NUMERIC-TYPE LOWER HIGHER))) (COMPLEX (CL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (ELEMENT-TYPE (QUOTE *))) LIST-TYPE (LIST NUMERIC-TYPE ELEMENT-TYPE))) (T TYPE))))
(DEFUN RANGE<= (LOW2 LOW1 HIGH1 HIGH2 TYPE1 TYPE2) (IL:* IL:|;;;| "Returns t if bound1 is less than or equal bound2, allowing for wildcards. ") (IF (EQ TYPE1 (QUOTE INTEGER)) (COND ((CONSP LOW1) (SETQ LOW1 (+ (CAR LOW1) 1))) ((CONSP HIGH1) (SETQ HIGH1 (- (CAR HIGH1) 1))))) (IF (EQ TYPE2 (QUOTE INTEGER)) (COND ((CONSP LOW2) (SETQ LOW2 (+ (CAR LOW2) 1))) ((CONSP HIGH2) (SETQ HIGH2 (- (CAR HIGH2) 1))))) (AND (IL:* IL:|;;| "check the low bounds") (COND ((EQ LOW2 (QUOTE *)) T) ((EQ LOW1 (QUOTE *)) NIL) (T (IF (CONSP LOW2) (IF (CONSP LOW1) (<= (CAR LOW2) (CAR LOW1)) (< (CAR LOW2) LOW1)) (IF (CONSP LOW1) (<= LOW2 (CAR LOW1)) (<= LOW2 LOW1))))) (IL:* IL:|;;| "Check the high bounds") (COND ((EQ HIGH2 (QUOTE *)) T) ((EQ HIGH1 (QUOTE *)) NIL) (T (IF (CONSP HIGH2) (IF (CONSP HIGH1) (>= (CAR HIGH2) (CAR HIGH1)) (> (CAR HIGH2) HIGH1)) (IF (CONSP HIGH1) (>= HIGH2 (CAR HIGH1)) (>= HIGH2 HIGH1)))))))
(DEFUN BASE-SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;| "Contains subtypep's special cases for base types.") (LET ((SYMBOL-TYPE1 (IF (CONSP TYPE1) (CAR TYPE1) TYPE1)) (SYMBOL-TYPE2 (IF (CONSP TYPE2) (CAR TYPE2) TYPE2))) (COND ((OR (EQ TYPE1 NIL) (EQ TYPE2 T) (EQUAL TYPE1 TYPE2)) (VALUES T T)) ((EQ TYPE2 (QUOTE COMMON)) (IL:* IL:\; "Common does not list it's subtypes in the lattice, since their presence indicates that they are in COMMON.") (IF (MEMBER SYMBOL-TYPE1 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)) (IL:* IL:|;;| "then this is part of common. Note this will include structures etc.") (VALUES T T) (VALUES NIL T))) ((OR (NOT (MEMBER SYMBOL-TYPE1 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ))) (NOT (MEMBER SYMBOL-TYPE2 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)))) (IL:* IL:\; "one of the types is something we can't reason about (for instance a user defined type that expands into satisfies.)") (VALUES NIL NIL)) (IL:* IL:|;;| "from this point on, we are only dealing with Common Lisp base types.") ((EQ TYPE1 T) (IL:* IL:\; "t is not a subtype of anything but t, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 NIL) (IL:* IL:\; "nil is not a supertype of anything but nil, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 (QUOTE ATOM)) (IL:* IL:|;;| "this case could be explicitly added to the type lattice. But if someone adds a base type, then they would have to remember to add it as a sub type of atom, (which they wouldn't.)") (IF (EQ TYPE1 (QUOTE CONS)) (IL:* IL:\; "this is the only base type that isn't a subtype of atom.") (VALUES NIL T) (VALUES T T))) ((NOT (OR (EQ SYMBOL-TYPE1 SYMBOL-TYPE2) (MEMBER SYMBOL-TYPE1 (ASSOC SYMBOL-TYPE2 *BASE-TYPE-LATTICE* :TEST (FUNCTION EQ)) :TEST (FUNCTION EQ)))) (IL:* IL:|;;| "since we are now dealing with only base types, we can make sure that type1 (without its arguments) is a subtype of type2, before checking the constraints on the arguments.") (VALUES NIL T)) (T (IL:* IL:|;;| "Now check the constraints on the type arguments.") (LET ((TYPE1 (COMPLETE-META-EXPRESSION-DEFAULTS TYPE1)) (TYPE2 (COMPLETE-META-EXPRESSION-DEFAULTS TYPE2))) (CASE (IF (CONSP TYPE1) (CAR TYPE1) TYPE1) ((ARRAY SIMPLE-ARRAY) (IL:* IL:|;;| "the type will look like (simple-array element-type dimensions)") (CL:DESTRUCTURING-BIND (ARRAY-TYPE1 ELEMENT-TYPE-1 DIMS-1) TYPE1 (CL:DESTRUCTURING-BIND (ARRAY-TYPE2 ELEMENT-TYPE-2 DIMS-2) TYPE2 (IF (AND (EQUAL-ELEMENT-TYPE ELEMENT-TYPE-1 ELEMENT-TYPE-2) (EQUAL-DIMENSIONS DIMS-1 DIMS-2)) (VALUES T T) (VALUES NIL T))))) ((:DATATYPE IL:DATATYPE) (IL:* IL:|;;| "we wouldn't have made it here if they weren't both datatypes, since only datatype is a subtype of datatype in the lattice.") (VALUES (SI::SUB-DATATYPE-P (CADR TYPE1) (CADR TYPE2)) T)) ((INTEGER RATIONAL FLOAT) (CASE TYPE2 (NUMBER (IL:* IL:|;;| "number doesn't take ranges, there's nothing to verify.") (VALUES T T)) (OTHERWISE (CL:DESTRUCTURING-BIND (NUMERIC-TYPE1 LOW1 HIGH1) TYPE1 (CL:DESTRUCTURING-BIND (NUMERIC-TYPE2 LOW2 HIGH2) TYPE2 (IF (RANGE<= LOW2 LOW1 HIGH1 HIGH2 NUMERIC-TYPE1 NUMERIC-TYPE2) (VALUES T T) (VALUES NIL T))))))) (COMPLEX (CASE TYPE2 (NUMBER (VALUES T T)) (OTHERWISE (IL:* IL:|;;| "typep2 must be complex") (LET ((ELT-TYPE1 (CADR TYPE1)) (ELT-TYPE2 (CADR TYPE2))) (COND ((EQ ELT-TYPE2 (QUOTE *)) (VALUES T T)) ((EQ ELT-TYPE1 (QUOTE *)) (VALUES NIL T)) (T (SUBTYPEP ELT-TYPE1 ELT-TYPE2))))))) (OTHERWISE (IL:* IL:|;;| "these are two base types. the lattice said they are subtypes, and there are no special rules on the arguments, so the result is (t t) if they are equal") (VALUES T T))))))))
(DEFUN EQUAL-ELEMENT-TYPE (ELEMENT-TYPE-1 ELEMENT-TYPE-2) (IL:* IL:|;;| "returns t if they are element types for compatible array types.") (COND ((EQ ELEMENT-TYPE-2 (QUOTE *)) T) ((EQ ELEMENT-TYPE-1 (QUOTE *)) NIL) (T (EQUAL (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE-1) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE-2)))))
(DEFUN USEFUL-TYPE-EXPANSION-P (EXPANSION EXPANDED) (IL:* IL:|;;| "a type expansion only gained information if some expansion happened and the result isn't solely a satisfies form.") (AND EXPANDED (NOT (AND (CONSP EXPANSION) (EQ (CAR EXPANSION) (QUOTE SATISFIES))))))
(IL:* IL:|;;;| "Basic deftypes")
(DEFTYPE ATOM NIL (QUOTE (SATISFIES ATOM)))
(DEFTYPE BIGNUM NIL (QUOTE (SATISFIES BIGNUMP)))
(DEFTYPE BIT NIL (QUOTE (INTEGER 0 1)))
(DEFTYPE CHARACTER NIL (QUOTE (SATISFIES CHARACTERP)))
(DEFTYPE CONS NIL (QUOTE (:DATATYPE IL:LISTP)))
(DEFTYPE DOUBLE-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
(DEFTYPE EQL (CL::VALUE) (IL:BQUOTE (SATISFIES (LAMBDA (CL::X) (EQL CL::X (QUOTE (IL:\\\, CL::VALUE)))))))
(DEFTYPE FIXNUM NIL (IL:BQUOTE (INTEGER (IL:\\\, MOST-NEGATIVE-FIXNUM) (IL:\\\, MOST-POSITIVE-FIXNUM))))
(DEFTYPE STREAM NIL (QUOTE (:DATATYPE STREAM)))
(DEFTYPE FLOAT (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (:DATATYPE IL:FLOATP)) LOW HIGH))
(DEFTYPE FUNCTION NIL (QUOTE (SATISFIES FUNCTIONP)))
(DEFTYPE HASH-TABLE NIL (QUOTE (:DATATYPE IL:HARRAYP)))
(DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (SATISFIES INTEGERP)) LOW HIGH (IL:BQUOTE (((IL:\\\, IL:MIN.INTEGER) (IL:\\\, IL:MAX.INTEGER) (SATISFIES INTEGERP)) ((IL:\\\, IL:MIN.FIXP) (IL:\\\, IL:MAX.FIXP) (OR (SATISFIES IL:SMALLP) (:DATATYPE IL:FIXP))) ((IL:\\\, IL:MIN.SMALLP) (IL:\\\, IL:MAX.SMALLP) (SATISFIES IL:SMALLP)) (0 1 (MEMBER 0 1))))))
(DEFTYPE KEYWORD NIL (QUOTE (SATISFIES KEYWORDP)))
(DEFTYPE LIST (&OPTIONAL TYPE) (IF (EQ TYPE (QUOTE *)) (QUOTE (OR NULL CONS)) (IL:BQUOTE (AND LIST (SATISFIES (LAMBDA (X) (EVERY (FUNCTION (LAMBDA (ELEMENT) (TYPEP ELEMENT (QUOTE (IL:\\\, TYPE))))) X)))))))
(DEFTYPE LONG-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
(DEFTYPE MEMBER (&REST VALUES) (IL:BQUOTE (SATISFIES (LAMBDA (X) (MEMBER X (QUOTE (IL:\\\, VALUES)))))))
(DEFTYPE MOD (N) (IL:BQUOTE (INTEGER 0 (IL:\\\, (1- N)))))
(DEFTYPE NULL NIL (QUOTE (SATISFIES NULL)))
(DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP)))
(DEFTYPE PACKAGE NIL (QUOTE (:DATATYPE PACKAGE)))
(DEFTYPE CL:REAL (&OPTIONAL CL::LOW CL::HIGH) (IL:* IL:|;;| "This is true in our implementation, but CLtL2 does not require it (it is legal for other things to be REAL; we just don't have any).") (%RANGE-TYPE (QUOTE (OR RATIONAL FLOAT)) CL::LOW CL::HIGH))
(DEFTYPE SHORT-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
(DEFTYPE SIGNED-BYTE (&OPTIONAL S) (IF (EQ S (QUOTE *)) (QUOTE INTEGER) (LET ((SIZE (EXPT 2 (1- S)))) (IL:BQUOTE (INTEGER (IL:\\\, (- SIZE)) (IL:\\\, (1- SIZE)))))))
(DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES STANDARD-CHAR-P)))
(DEFTYPE STRING-CHAR NIL (QUOTE (AND CHARACTER (SATISFIES STRING-CHAR-P))))
(DEFTYPE CL:BASE-CHARACTER NIL (QUOTE (SATISFIES CL::BASE-CHARACTER-P)))
(DEFTYPE CL:EXTENDED-CHARACTER NIL (QUOTE (SATISFIES CL::EXTENDED-CHARACTER-P)))
(DEFTYPE SINGLE-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
(DEFTYPE SYMBOL NIL (QUOTE (:DATATYPE IL:LITATOM)))
(DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (IF (EQ S (QUOTE *)) (QUOTE (INTEGER 0 *)) (IL:BQUOTE (INTEGER 0 ((IL:\\\, (EXPT 2 S)))))))
(DEFTYPE RATIONAL (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (OR RATIO INTEGER)) LOW HIGH))
(DEFTYPE READTABLE NIL (QUOTE (:DATATYPE READTABLEP)))
(DEFTYPE COMMON NIL (IL:* IL:|;;| "This is a hack. (You can tell, because it uses TYPE-OF.) However, it is correct. (Note that even though subtypep uses expanders, there is no danger of a loop because it quits when it reachs a satisfies clause.)") (IL:BQUOTE (SATISFIES (LAMBDA (OBJ) (VALUES (SUBTYPEP (TYPE-OF OBJ) (QUOTE COMMON)))))))
(DEFTYPE COMPILED-FUNCTION NIL (QUOTE (SATISFIES COMPILED-FUNCTION-P)))
(DEFTYPE SEQUENCE (&OPTIONAL TYPE) (IL:* IL:|;;| "Larry's dubious extension, that I can't remove because he wrote code that relies on it. Actually the extension is somewhat useful, but confusing. (it simulates the DECL facility for saying (LIST user-type).)") (IF (EQ TYPE (QUOTE *)) (QUOTE (OR VECTOR LIST)) (IL:BQUOTE (AND SEQUENCE (SATISFIES (LAMBDA (X) (EVERY (FUNCTION (LAMBDA (ELEMENT) (TYPEP ELEMENT (QUOTE (IL:\\\, TYPE))))) X)))))))
(IL:* IL:|;;;| "Array Types")
(DEFTYPE ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) (IL:* IL:|;;;| "This type definition should not return anything other than satisfies. Other array types are determined in terms of this one, (for subtypep's sake) so this one must bottom out.") (LET ((CANONICAL-ET (IF (EQ ELEMENT-TYPE (QUOTE *)) (QUOTE *) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))) (IF (TYPEP DIMENSIONS (QUOTE FIXNUM)) (SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))) (COND ((EQ DIMENSIONS (QUOTE *)) (IF (EQ CANONICAL-ET (QUOTE *)) (QUOTE (SATISFIES ARRAYP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))) ((EQ (LENGTH DIMENSIONS) 1) (LET ((SIZE (CAR DIMENSIONS))) (COND ((EQ CANONICAL-ET (QUOTE *)) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES VECTORP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (VECTORP X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) ((EQ CANONICAL-ET (QUOTE CL:BASE-CHARACTER)) (IL:* IL:|;;| "CL:BASE-CHARACTER is the canonical type for CL:BASE-CHARACTER, CHARACTER, and STRING-CHAR. For typing purposes, they have to explicitly say CL:BASE-CHARACTER to recognize only thin strings.") (IF (EQ ELEMENT-TYPE (QUOTE CL:BASE-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (IL:%THIN-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES STRINGP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))) ((EQ CANONICAL-ET (QUOTE CL:EXTENDED-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (IL:%FAT-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))))) ((OR (EQ CANONICAL-ET (QUOTE BIT)) (EQUAL CANONICAL-ET (QUOTE (UNSIGNED-BYTE 1)))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES BIT-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (BIT-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) (T (IL:* IL:|;;| "vector of explicit element-type") (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (VECTORP X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (EQ DIM (QUOTE *)))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (OR (EQ DIM (QUOTE *)) (TYPEP DIM (QUOTE FIXNUM))))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (DO ((DIM-SPEC DIMENSIONS (CDR DIM-SPEC)) (DIM 0 (1+ DIM)) FORMS) ((NULL DIM-SPEC) FORMS) (IF (NOT (EQ (CAR DIM-SPEC) (QUOTE *))) (PUSH (IL:BQUOTE (EQ (ARRAY-DIMENSION X (IL:\\\, DIM)) (IL:\\\, (CAR DIM-SPEC)))) FORMS)))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) (T (ERROR "Bad (final) array type designator: ~S" (IL:BQUOTE (ARRAY (IL:\\\, CANONICAL-ET) (IL:\\\, DIMENSIONS))))))))
(DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (IL:* IL:|;;| "this type must be defined in terms of array so that subtypep can reason(?) about them.") (IL:BQUOTE (ARRAY (IL:\\\, ELEMENT-TYPE) ((IL:\\\, SIZE)))))
(DEFTYPE STRING (&OPTIONAL SIZE) (IL:BQUOTE (ARRAY STRING-CHAR ((IL:\\\, SIZE)))))
(DEFTYPE SIMPLE-STRING (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY STRING-CHAR ((IL:\\\, SIZE)))))
(DEFTYPE SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) (IL:* IL:|;;| "Simple-array type expander") (LET ((CANONICAL-ET (IF (EQ ELEMENT-TYPE (QUOTE *)) (QUOTE *) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))) (IF (TYPEP DIMENSIONS (QUOTE FIXNUM)) (SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))) (IL:* IL:|;;| "at this point, dimensions is always a list of integers or *'s, and element-type is a canonical type.") (COND ((EQ DIMENSIONS (QUOTE *)) (IF (EQ CANONICAL-ET (QUOTE *)) (QUOTE (SATISFIES XCL:SIMPLE-ARRAY-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))) ((EQ (LENGTH DIMENSIONS) 1) (LET ((SIZE (CAR DIMENSIONS))) (COND ((EQ CANONICAL-ET (QUOTE CL:BASE-CHARACTER)) (IF (EQ ELEMENT-TYPE (QUOTE CL:BASE-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (IL:%THIN-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-STRING-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))) ((EQ CANONICAL-ET (QUOTE CL:EXTENDED-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (IL:%FAT-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))))) ((OR (EQ CANONICAL-ET (QUOTE BIT)) (EQUAL CANONICAL-ET (QUOTE (UNSIGNED-BYTE 1)))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-BIT-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-BIT-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) ((EQ CANONICAL-ET T) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) (T (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ 1 (ARRAY-RANK X)) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (EQ DIM (QUOTE *)))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (OR (EQ DIM (QUOTE *)) (TYPEP DIM (QUOTE FIXNUM))))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (DO ((DIM-SPEC DIMENSIONS (CDR DIM-SPEC)) (DIM 0 (1+ DIM)) FORMS) ((NULL DIM-SPEC) FORMS) (IF (NOT (EQ (CAR DIM-SPEC) (QUOTE *))) (PUSH (IL:BQUOTE (EQ (ARRAY-DIMENSION X (IL:\\\, DIM)) (IL:\\\, (CAR DIM-SPEC)))) FORMS)))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) (T (ERROR "Bad (final) array type designator: ~S" (IL:BQUOTE (SIMPLE-ARRAY (IL:\\\, CANONICAL-ET) (IL:\\\, DIMENSIONS))))))))
(DEFTYPE SIMPLE-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY T ((IL:\\\, SIZE)))))
(DEFTYPE BIT-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (ARRAY (UNSIGNED-BYTE 1) ((IL:\\\, SIZE)))))
(DEFTYPE SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY (UNSIGNED-BYTE 1) ((IL:\\\, SIZE)))))
(DEFTYPE CL:BASE-STRING (&OPTIONAL CL::SIZE) (IL:BQUOTE (ARRAY CL:BASE-CHARACTER ((IL:\\\, CL::SIZE)))))
(DEFTYPE CL:SIMPLE-BASE-STRING (&OPTIONAL CL::SIZE) (IL:BQUOTE (SIMPLE-ARRAY CL:BASE-CHARACTER ((IL:\\\, CL::SIZE)))))
(IL:* IL:|;;;| "Stream types required by CLtL2")
(DEFTYPE CL:BROADCAST-STREAM NIL (IL:BQUOTE (AND STREAM (SATISFIES XCL:BROADCAST-STREAM-P))))
(DEFTYPE CL:CONCATENATED-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:CONCATENATED-STREAM-P))))
(DEFTYPE CL:ECHO-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:ECHO-STREAM-P))))
(DEFTYPE CL:SYNONYM-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:SYNONYM-STREAM-P))))
(DEFTYPE CL:STRING-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:STRING-STREAM-P))))
(DEFTYPE CL:FILE-STREAM NIL (QUOTE (AND STREAM (SATISFIES CL::FILE-STREAM-P))))
(DEFTYPE CL:TWO-WAY-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:TWO-WAY-STREAM-P))))
(IL:* IL:|;;;| "Fast predicates for typep")
(XCL:DEF-DEFINE-TYPE TYPEP "Typep evaluator for a type")
(XCL:DEFDEFINER DEFTYPEP TYPEP (NAME TYPE-ARGS OBJECT-ARG &BODY BODY) (IL:* IL:|;;;| "The comment below is not necessarily true for deftype, so until the PavCompiler groks deftype, leave the eval-when alone.") (IL:* IL:|;;| "The EVAL-WHEN below should be a PROGN as soon as the old ByteCompiler/COMPILE-FILE hack is done away with. The PavCompiler understands DEFMACRO's correctly and doesn't side-effect the environment.") (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPEP: ~S" NAME)) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOCSTRING) (IL:PARSE-DEFMACRO TYPE-ARGS (QUOTE SI::%$$TYPE-ARGS) BODY NAME NIL :DEFAULT-DEFAULT (QUOTE (QUOTE *)) :PATH (QUOTE SI::%$$TYPE-ARGS)) (LET ((TYPEP-NAME (XCL:PACK (LIST "typep-evaluate-" NAME) (SYMBOL-PACKAGE NAME)))) (IL:* IL:|;;| "the eval-when insures that the functions in the hash table are always compiled") (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPEP-NAME))) (FUNCTION (LAMBDA (SI::%$$OBJECT &OPTIONAL SI::%$$TYPE-ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (LET (((IL:\\\, (CAR OBJECT-ARG)) SI::%$$OBJECT)) (IL:\\\, PARSED-BODY)))))) (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE*) (QUOTE (IL:\\\, TYPEP-NAME))) (IL:\\\,@ (AND DOCSTRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE TYPEP)) (IL:\\\, DOCSTRING))))))) (EVAL-WHEN (EVAL) (IL:* IL:|;;| "With redefinition, clear the hash table") (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE*) NIL)))))))
(DEFTYPEP LIST (&OPTIONAL ELEMENT-TYPE) (OBJECT) (AND (LISTP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (DOLIST (L OBJECT T) (IF (NOT (TYPEP L ELEMENT-TYPE)) (RETURN NIL))))))
(DEFTYPEP SEQUENCE (&OPTIONAL ELEMENT-TYPE) (OBJECT) (AND (TYPEP OBJECT (QUOTE SEQUENCE)) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EVERY (FUNCTION (LAMBDA (S) (TYPEP S ELEMENT-TYPE))) OBJECT))))
(DEFTYPEP MEMBER (&REST VALUES) (OBJECT) (MEMBER OBJECT VALUES))
(DEFTYPEP ARRAY (&OPTIONAL ELEMENT-TYPE DIMS) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (ARRAYP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (SUBTYPEP (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (COND ((EQ DIMS (QUOTE *)) T) ((TYPEP DIMS (QUOTE FIXNUM)) (EQ (ARRAY-RANK OBJECT) DIMS)) (T (IL:* IL:|;;| "Must be a cons") (AND (EQ (ARRAY-RANK OBJECT) (LENGTH DIMS)) (DO ((I 0 (1+ I)) (D DIMS (CDR D))) ((NULL D) T) (IF (AND (TYPEP (CAR D) (QUOTE FIXNUM)) (NOT (EQ (ARRAY-DIMENSION OBJECT I) (CAR D)))) (RETURN NIL))))))))
(DEFTYPEP SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMS) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (XCL:SIMPLE-ARRAY-P OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (COND ((EQ DIMS (QUOTE *)) T) ((TYPEP DIMS (QUOTE FIXNUM)) (EQ (ARRAY-RANK OBJECT) DIMS)) (T (IL:* IL:|;;| "Must be a cons") (AND (EQ (ARRAY-RANK OBJECT) (LENGTH DIMS)) (DO ((I 0 (1+ I)) (D DIMS (CDR D))) ((NULL D) T) (IF (AND (TYPEP (CAR D) (QUOTE FIXNUM)) (NOT (EQ (ARRAY-DIMENSION OBJECT I) (CAR D)))) (RETURN NIL))))))))
(DEFTYPEP VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (VECTORP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
(DEFTYPEP SIMPLE-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
(DEFTYPEP COMPLEX (&OPTIONAL TYPE) (OBJECT) (AND (COMPLEXP OBJECT) (IF (EQ TYPE (QUOTE *)) T (AND (TYPEP (REALPART OBJECT) TYPE) (TYPEP (IMAGPART OBJECT) TYPE)))))
(DEFTYPEP INTEGER (&OPTIONAL LOW HIGH) (OBJECT) (AND (INTEGERP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
(DEFTYPEP MOD (&OPTIONAL N) (OBJECT) (AND (INTEGERP OBJECT) (>= OBJECT 0) (IF (EQ N (QUOTE *)) T (> N OBJECT))))
(DEFTYPEP SIGNED-BYTE (&OPTIONAL S) (OBJECT) (AND (INTEGERP OBJECT) (IF (EQ S (QUOTE *)) T (LET ((BOUND (ASH 1 (1- S)))) (AND (>= OBJECT (- BOUND)) (> BOUND OBJECT))))))
(DEFTYPEP UNSIGNED-BYTE (&OPTIONAL S) (OBJECT) (AND (INTEGERP OBJECT) (>= OBJECT 0) (IF (EQ S (QUOTE *)) T (> (ASH 1 S) OBJECT))))
(DEFTYPEP RATIONAL (&OPTIONAL LOW HIGH) (OBJECT) (AND (RATIONALP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
(DEFTYPEP FLOAT (&OPTIONAL LOW HIGH) (OBJECT) (AND (FLOATP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
(DEFTYPEP STRING (&OPTIONAL SIZE) (OBJECT) (AND (STRINGP OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
(DEFTYPEP SIMPLE-STRING (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-STRING-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
(DEFTYPEP BIT-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (BIT-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
(DEFTYPEP SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-BIT-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
(DEFTYPEP EQL (CL::VALUE) (CL::OBJECT) (EQL CL::OBJECT CL::VALUE))
(DEFTYPEP CL:REAL (&OPTIONAL CL::LOW CL::HIGH) (CL::OBJECT) (AND (OR (RATIONAL CL::OBJECT) (FLOATP CL::OBJECT)) (COND ((EQ CL::LOW (QUOTE *)) T) ((CONSP CL::LOW) (> CL::OBJECT (CAR CL::LOW))) (T (>= CL::OBJECT CL::LOW))) (COND ((EQ CL::HIGH (QUOTE *)) T) ((CONSP CL::HIGH) (> (CAR CL::HIGH) CL::OBJECT)) (T (>= CL::HIGH CL::OBJECT)))))
(IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names")
(IL:PUTPROPS IL:CHARACTER CMLTYPE CHARACTER)
(IL:PUTPROPS IL:FIXP CMLTYPE BIGNUM)
(IL:PUTPROPS IL:FLOATP CMLTYPE SINGLE-FLOAT)
(IL:PUTPROPS IL:GENERAL-ARRAY CMLTYPE ARRAY)
(IL:PUTPROPS IL:LISTP CMLTYPE CONS)
(IL:PUTPROPS IL:LITATOM CMLTYPE SYMBOL)
(IL:PUTPROPS IL:ONED-ARRAY CMLTYPE ARRAY)
(IL:PUTPROPS IL:SMALLP CMLTYPE FIXNUM)
(IL:PUTPROPS IL:HARRAYP CMLTYPE HASH-TABLE)
(IL:PUTPROPS IL:TWOD-ARRAY CMLTYPE ARRAY)
(IL:PUTPROPS SYMBOL CMLSUBTYPE-DESCRIMINATOR SYMBOL-TYPE)
(IL:PUTPROPS ARRAY CMLSUBTYPE-DESCRIMINATOR ARRAY-TYPE)
(IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property")
(IL:PUTPROPS :TYPE-EXPANDER IL:PROPTYPE IGNORE)
(IL:PUTPROPS IL:TYPE-EXPANDER IL:PROPTYPE IGNORE)
(IL:* IL:|;;;| "Compiler options")
(IL:PUTPROPS IL:CMLTYPES IL:FILETYPE COMPILE-FILE)
(IL:PUTPROPS IL:CMLTYPES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
(IL:LOCALVARS . T)
)
)
(IL:PUTPROPS IL:CMLTYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992 1993)
)
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL)))
IL:STOP