(FILECREATED " 1-Aug-85 16:38:00" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;8 10233
changes to: (FNS COERCE TYPEP \COERCE.FUNCTION \RANGE.TYPE \TYPEP.EXPAND.MACRO \TYPEP.PRED) (
TYPES DOUBLE-FLOAT LONG-FLOAT SHORT-FLOAT SINGLE-FLOAT ARRAY BIT CONS FIXNUM BIGNUM FLOAT HASH-TABLE
INTEGER KEYWORD MOD NUMBER SIGNED-BYTE SYMBOL SIMPLE-STRING) (MACROS TYPEP COERCE) (VARS CMLTYPESCOMS)
(PROPS (SIMPLE-STRING TYPE-COERCE))
previous date: "29-Jul-85 02:24:39" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;2)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLTYPESCOMS)
(RPAQQ CMLTYPESCOMS ((MACROS COERCE DEFTYPE NILL TRUE TYPEP CHECK-TYPE THE) (PROP PROPTYPE DEFTYPE
TYPE-DOCUMENTATION TYPE-PREDICATE) (FNS COERCE ENUMERATED-TYPES-OF TYPE-OF TYPEP TYPES.GETDEF
\COERCE.FUNCTION \RANGE.TYPE \TYPEP.EXPAND.MACRO \TYPEP.PRED) (P (MOVD (QUOTE STRINGP) (QUOTE
SIMPLE-STRING-P)) (MOVD (QUOTE TYPENAMEP) (QUOTE STRUCTURE-TYPEP)) (ADDTOVAR SYSPROPS DEFTYPE
TYPE-DOCUMENTATION)) (FILEPKGCOMS TYPES) (TYPES ATOM BIGNUM BIT CONS DOUBLE-FLOAT FIXNUM FLOAT
HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT MEMBER MOD NULL NUMBER SHORT-FLOAT SIGNED-BYTE
SIMPLE-STRING SINGLE-FLOAT STRING SYMBOL UNSIGNED-BYTE) (PROP CMLTYPE ARRAYP CMLARRAY FIXP FLOATP
LISTP LITATOM SMALLP STRINGP) (PROP TYPE-COERCE CHARACTER FLOAT SIMPLE-STRING) (VARS (\COERCEMACROHASH
(HASHARRAY 30)))))
(DECLARE: EVAL@COMPILE
(PUTPROPS COERCE DMACRO (DEFMACRO (OBJ TYPESPEC) (LET* ((CE (CONSTANTEXPRESSIONP TYPESPEC)) (CF (AND
CE (\COERCE.FUNCTION (CAR CE))))) (if CF then (LIST CF OBJ) else (QUOTE IGNOREMACRO)))))
(DEFMACRO DEFTYPE (NAME LAMBDA-LIST &REST REST) (* doesn't return right value) (LET ((DOC (if (STRINGP
(CAR REST)) then (pop REST)))) (BQUOTE (PUTPROPS (\, NAME) DEFTYPE (MACRO (\, LAMBDA-LIST) (\, (
MKPROGN REST))) (\,@ (AND DOC (BQUOTE ((\, NAME) TYPE-DOCUMENTATION (\, DOC)))))))))
(PUTPROPS NILL DMACRO (DEFMACRO BODY (BQUOTE (PROG1 NIL (\,@ BODY)))))
(PUTPROPS TRUE DMACRO (DEFMACRO BODY (BQUOTE (PROG1 T (\,@ BODY)))))
(PUTPROPS TYPEP DMACRO (DEFMACRO (OBJ TYPESPEC) (LET ((CE (CONSTANTEXPRESSIONP TYPESPEC))) (if CE then
(BQUOTE (AND (, (\TYPEP.PRED (CAR CE)) , OBJ) T)) else (QUOTE IGNOREMACRO)))))
(DEFMACRO CHECK-TYPE (PLACE TYPESPEC &OPTIONAL STRING) (BQUOTE (PROG NIL TOP (if (TYPEP (\, PLACE) (
QUOTE (\, TYPESPEC))) then (RETURN T)) (SETF (\, PLACE) (\CHECK-TYPE-FAIL (QUOTE (\, PLACE)) (\, (OR
STRING (BQUOTE (QUOTE (\, TYPESPEC))))))) (GO TOP))))
(PUTPROPS THE MACRO ((TYPESPEC PLACE) (PROG ((VAL PLACE)) RETRY (RETURN (IF (TYPEP VAL (QUOTE TYPESPEC
)) THEN VAL ELSE (SETQ VAL (\CHECK-TYPE-FAIL (QUOTE TYPESPEC) VAL)) (GO RETRY))))))
)
(PUTPROPS DEFTYPE PROPTYPE TYPES)
(PUTPROPS TYPE-DOCUMENTATION PROPTYPE TYPES)
(PUTPROPS TYPE-PREDICATE PROPTYPE TYPES)
(DEFINEQ
(COERCE
(LAMBDA (OBJECT RESULT-TYPE) (* lmm "31-Jul-85 03:48") (if (TYPEP OBJECT RESULT-TYPE) then OBJECT else
(FUNCALL (\COERCE.FUNCTION RESULT-TYPE) OBJECT))))
(ENUMERATED-TYPES-OF
[LAMBDA NIL (* edited: "26-Jul-85 20:16")
(for X in (DATATYPES) collect (OR (GETPROP X (QUOTE CMLTYPE))
X])
(TYPE-OF
[LAMBDA (X)
(LET ((TYPE (TYPENAME X)))
(OR (GETPROP TYPE (QUOTE CMLTYPE))
TYPE])
(TYPEP
(LAMBDA (OBJECT TYPE) (* lmm " 1-Aug-85 12:07") (AND (FUNCALL (\TYPEP.PRED TYPE) OBJECT) T)))
(TYPES.GETDEF
[LAMBDA (NAME) (* lmm "18-Jul-85 21:03")
(PROG [(PROP (GETPROP NAME (QUOTE DEFTYPE)))
(DOC (GETPROP NAME (QUOTE TYPE-DOCUMENTATION)))
(TYPE-PREDICATE (GETPROP NAME (QUOTE TYPE-PREDICATE]
(RETURN (MKPROGN (APPEND (AND (OR PROP DOC)
(SELECTQ (CAR PROP)
[MACRO (BQUOTE ((DEFTYPE (\, NAME)
(\, (CAR (CDR PROP)))
(\,@ (AND DOC (LIST DOC)))
(\, (CADR (CDR PROP]
(HELP)))
(AND TYPE-PREDICATE (BQUOTE ((PUTPROPS (\, NAME)
TYPE-PREDICATE
(\, TYPE-PREDICATE])
(\COERCE.FUNCTION
(LAMBDA (TYPE) (* lmm "31-Jul-85 13:28") (if (LISTP TYPE) then (OR (GETHASH TYPE \COERCEMACROHASH) (
PUTHASH TYPE (SELECTQ (CAR TYPE) (SATISFIES (SHOULDNT)) (AND (if (NULL (CDDR TYPE)) then (
\COERCE.FUNCTION (CADR TYPE)) else (BQUOTE (LAMBDA (X) ((\, (\COERCE.FUNCTION (CONS (QUOTE AND) (CDDR
TYPE)))) ((\, (\COERCE.FUNCTION (CADR TYPE))) X)))))) ((OR NOT) (SHOULDNT)) (LET ((PROP (GETPROP (CAR
TYPE) (QUOTE DEFTYPE)))) (SELECTQ (CAR PROP) (MACRO (\COERCE.FUNCTION (\TYPEP.EXPAND.MACRO PROP TYPE))
) (HELP)))) \COERCEMACROHASH)) else (SELECTQ TYPE (T (QUOTE IDENTITY)) (NIL (QUOTE (LAMBDA (X) (ERROR
"can't coerce" X)))) (OR (GETPROP TYPE (QUOTE TYPE-COERCE)) (PROGN (PRINTOUT T
"Warning: No COERCE function for " TYPE T) NIL))))))
(\RANGE.TYPE
(LAMBDA (BASETYPE LOW HIGH RANGELIST) (* lmm " 1-Aug-85 12:02") (if (NULL LOW) then (SETQ LOW (QUOTE *
))) (OR HIGH (SETQ HIGH (QUOTE *))) (if (AND (EQ LOW (QUOTE *)) (EQ HIGH (QUOTE *))) then BASETYPE
else (for X in RANGELIST when (AND (EQUAL LOW (CAR X)) (EQUAL HIGH (CADR X))) do (RETURN (CADDR X))
finally (RETURN (BQUOTE (AND , BASETYPE (SATISFIES (LAMBDA (X) (AND (\,@ (if (NEQ LOW (QUOTE *)) then
(BQUOTE (((\, (if (LISTP LOW) then (SETQ LOW (CAR LOW)) (QUOTE <) else (QUOTE <=))) (\, LOW) X))))) (
\,@ (if (NEQ HIGH (QUOTE *)) then (BQUOTE (((\, (if (LISTP HIGH) then (SETQ HIGH (CAR HIGH)) (QUOTE <)
else (QUOTE <=))) X (\, HIGH))))))))))))))))
(\TYPEP.EXPAND.MACRO
(LAMBDA (PROP TYPE) (* lmm "18-Jul-85 20:38") (DEFMACRO.EXPAND (CADR PROP) TYPE (CADDR PROP) (QUOTE *)
)))
(\TYPEP.PRED
(LAMBDA (TYPE) (* lmm " 1-Aug-85 11:52") (if (LISTP TYPE) then (OR (GETHASH TYPE CLISPARRAY) (PUTHASH
TYPE (SELECTQ (CAR TYPE) (SATISFIES (CADR TYPE)) (DATATYPE (BQUOTE (OPENLAMBDA (X) (TYPENAMEP X (QUOTE
(\, (CADR TYPE))))))) ((AND OR NOT) (BQUOTE (OPENLAMBDA (X) (, (CAR TYPE) (\,@ (for PRED in (CDR TYPE
) collect (LIST (\TYPEP.PRED PRED) (QUOTE X)))))))) (LET ((PROP (GETPROP (CAR TYPE) (QUOTE DEFTYPE))))
(SELECTQ (CAR PROP) (MACRO (\TYPEP.PRED (\TYPEP.EXPAND.MACRO PROP TYPE))) (HELP
"undefined type used in TYPEP")))) CLISPARRAY)) else (SELECTQ TYPE (T (QUOTE TRUE)) (NIL (QUOTE NILL))
(LET ((PROP (GETPROP TYPE (QUOTE DEFTYPE)))) (SELECTQ (CAR PROP) (MACRO (\TYPEP.PRED (
\TYPEP.EXPAND.MACRO PROP (LIST TYPE)))) (PROGN (PRINTOUT T "Warning: type " TYPE
" assumed to be datatype" T) (/PUTPROP TYPE (QUOTE DEFTYPE) (BQUOTE (MACRO NIL (QUOTE (DATATYPE , TYPE
))))) (\TYPEP.PRED TYPE))))))))
)
(MOVD (QUOTE STRINGP) (QUOTE SIMPLE-STRING-P))
(MOVD (QUOTE TYPENAMEP) (QUOTE STRUCTURE-TYPEP))
(ADDTOVAR SYSPROPS DEFTYPE TYPE-DOCUMENTATION)
(PUTDEF (QUOTE TYPES) (QUOTE FILEPKGCOMS) (QUOTE ((TYPE DESCRIPTION "type specifiers" GETDEF
TYPES.GETDEF))))
(PUTDEF (QUOTE ATOM) (QUOTE TYPES) (QUOTE (PUTPROPS ATOM TYPE-PREDICATE NLISTP)))
(PUTDEF (QUOTE BIGNUM) (QUOTE TYPES) (QUOTE (DEFTYPE BIGNUM NIL (QUOTE (DATATYPE BIGNUM)))))
(PUTDEF (QUOTE BIT) (QUOTE TYPES) (QUOTE (DEFTYPE BIT NIL (QUOTE (MOD 2)))))
(PUTDEF (QUOTE CONS) (QUOTE TYPES) (QUOTE (DEFTYPE CONS NIL (QUOTE (DATATYPE LISTP)))))
(PUTDEF (QUOTE DOUBLE-FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE DOUBLE-FLOAT (&REST X) (CONS (QUOTE FLOAT)
X))))
(PUTDEF (QUOTE FIXNUM) (QUOTE TYPES) (QUOTE (DEFTYPE FIXNUM NIL (QUOTE (DATATYPE SMALLP)))))
(PUTDEF (QUOTE FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE FLOAT (&OPTIONAL LOW HIGH) (\RANGE.TYPE (QUOTE (
DATATYPE FLOATP)) LOW HIGH))))
(PUTDEF (QUOTE HASH-TABLE) (QUOTE TYPES) (QUOTE (DEFTYPE HASH-TABLE NIL (QUOTE (DATATYPE HARRAYP)))))
(PUTDEF (QUOTE INTEGER) (QUOTE TYPES) (QUOTE (DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (\RANGE.TYPE (QUOTE
(SATISFIES FIXP)) LOW HIGH (QUOTE ((-65536 65535 FIXNUM) (0 1 (MEMBER 0 1))))))))
(PUTDEF (QUOTE KEYWORD) (QUOTE TYPES) (QUOTE (DEFTYPE KEYWORD NIL (QUOTE (SATISFIES \KEYWORDP)))))
(PUTDEF (QUOTE LIST) (QUOTE TYPES) (QUOTE (DEFTYPE LIST NIL (QUOTE (OR CONS NULL)))))
(PUTDEF (QUOTE LONG-FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE LONG-FLOAT (&REST X) (CONS (QUOTE FLOAT) X)))
)
(PUTDEF (QUOTE MEMBER) (QUOTE TYPES) (QUOTE (DEFTYPE MEMBER (&REST VALUES) (BQUOTE (SATISFIES (LAMBDA
(X) (CL:MEMBER X (QUOTE (\, VALUES)))))))))
(PUTDEF (QUOTE MOD) (QUOTE TYPES) (QUOTE (DEFTYPE MOD (N) (BQUOTE (INTEGER 0 (\, (SUB1 N)))))))
(PUTDEF (QUOTE NULL) (QUOTE TYPES) (QUOTE (DEFTYPE NULL NIL (QUOTE (MEMBER NIL)))))
(PUTDEF (QUOTE NUMBER) (QUOTE TYPES) (QUOTE (DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP)))))
(PUTDEF (QUOTE SHORT-FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE SHORT-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
REST))))
(PUTDEF (QUOTE SIGNED-BYTE) (QUOTE TYPES) (QUOTE (DEFTYPE SIGNED-BYTE (&OPTIONAL S) (if (EQ S (QUOTE *
)) then (QUOTE INTEGER) else (BQUOTE (INTEGER (\, (MINUS (SETQ S (EXPT 2 (SUB1 S))))) (\, (SUB1 S)))))
)))
(PUTDEF (QUOTE SIMPLE-STRING) (QUOTE TYPES) (QUOTE (DEFTYPE SIMPLE-STRING NIL (QUOTE (SATISFIES
STRINGP)))))
(PUTDEF (QUOTE SINGLE-FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE SINGLE-FLOAT (&REST REST) (CONS (QUOTE
FLOAT) REST))))
(PUTDEF (QUOTE STRING) (QUOTE TYPES) (QUOTE (DEFTYPE STRING (&OPTIONAL SIZE) (if (OR (NULL SIZE) (EQ
SIZE (QUOTE *))) then (QUOTE (SATISFIES STRINGP)) else (BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X)
(EQL (NCHARS X) (\, SIZE))))))))))
(PUTDEF (QUOTE SYMBOL) (QUOTE TYPES) (QUOTE (DEFTYPE SYMBOL NIL (QUOTE (DATATYPE LITATOM)))))
(PUTDEF (QUOTE UNSIGNED-BYTE) (QUOTE TYPES) (QUOTE (DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (if (EQ S (
QUOTE *)) then (QUOTE (INTEGER 0)) else (BQUOTE (INTEGER 0 ((\, (EXPT 2 S)))))))))
(PUTPROPS ARRAYP CMLTYPE ARRAY)
(PUTPROPS CMLARRAY CMLTYPE ARRAY)
(PUTPROPS FIXP CMLTYPE BIGNUM)
(PUTPROPS FLOATP CMLTYPE SINGLE-FLOAT)
(PUTPROPS LISTP CMLTYPE CONS)
(PUTPROPS LITATOM CMLTYPE SYMBOL)
(PUTPROPS SMALLP CMLTYPE FIXNUM)
(PUTPROPS STRINGP CMLTYPE STRING)
(PUTPROPS CHARACTER TYPE-COERCE CL:CHARACTER)
(PUTPROPS FLOAT TYPE-COERCE FLOAT)
(PUTPROPS SIMPLE-STRING TYPE-COERCE MKSTRING)
(RPAQ \COERCEMACROHASH (HASHARRAY 30))
(PUTPROPS CMLTYPES COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2811 6667 (COERCE 2821 . 2987) (ENUMERATED-TYPES-OF 2989 . 3216) (TYPE-OF 3218 . 3348)
(TYPEP 3350 . 3454) (TYPES.GETDEF 3456 . 4176) (\COERCE.FUNCTION 4178 . 4936) (\RANGE.TYPE 4938 . 5612
) (\TYPEP.EXPAND.MACRO 5614 . 5745) (\TYPEP.PRED 5747 . 6665)))))
STOP