(FILECREATED "26-Sep-85 03:34:12" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;13
 11934  

      changes to:  (VARS CMLTYPESCOMS)

      previous date: "12-Sep-85 01:06:42" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;12)


(* 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 CHARACTER CONS DOUBLE-FLOAT FIXNUM 
FLOAT HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT MEMBER MOD NULL NUMBER SHORT-FLOAT SIGNED-BYTE 
STANDARD-CHAR SIMPLE-STRING SINGLE-FLOAT STRING SYMBOL UNSIGNED-BYTE) (TYPES ARRAY VECTOR) (PROP 
CMLTYPE ARRAYP CMLARRAY FIXP FLOATP LISTP LITATOM SMALLP STRINGP) (PROP TYPE-COERCE CHARACTER FLOAT 
SIMPLE-STRING) (VARS (\COERCEMACROHASH (HASHARRAY 30))) (MACROS TYPECASE)))
(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 CHARACTER) (QUOTE TYPES) (QUOTE (DEFTYPE CHARACTER NIL (QUOTE (SATISFIES CHARACTERP))))
)
(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 STANDARD-CHAR) (QUOTE TYPES) (QUOTE (DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES 
STANDARD-CHAR-P)))))
(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)))))))))
(PUTDEF (QUOTE ARRAY) (QUOTE TYPES) (QUOTE (DEFTYPE ARRAY (&OPTIONAL (ELEMENT-TYPE (QUOTE *)) (
DIMENSIONS (QUOTE *))) (PROGN (if (AND (NLISTP DIMENSIONS) (NEQ DIMENSIONS (QUOTE *))) then (SETQ 
DIMENSIONS (to DIMENSIONS collect (QUOTE *)))) (if (AND (EQ ELEMENT-TYPE (QUOTE STRING-CHAR)) (ILESSP 
(LENGTH DIMENSIONS) 2)) then (if (MEMBER DIMENSIONS (QUOTE (* (*)))) then (QUOTE (DATATYPE STRINGP)) 
else (BQUOTE (AND (DATATYPE STRINGP) (SATISFIES (LAMBDA (X) (= (NCHARS X) , (CAR DIMENSIONS))))))) 
elseif (NEQ ELEMENT-TYPE (QUOTE *)) then (BQUOTE (AND (ARRAY * (\, DIMENSIONS)) (SATISFIES (LAMBDA (X)
 (EQ (ARRAY-ELEMENT-TYPE X) (QUOTE (\, ELEMENT-TYPE))))))) else (PROGN (if (AND (EQ ELEMENT-TYPE (
QUOTE *)) (EQ DIMENSIONS (QUOTE *))) then (QUOTE (OR (DATATYPE ARRAY) (DATATYPE STRINGP) (DATATYPE 
ARRAYP) (DATATYPE BITMAP))) elseif (EQUAL DIMENSIONS (QUOTE (*))) then (if (EQ ELEMENT-TYPE (QUOTE 
STRING-CHAR)) then (QUOTE STRING) else (QUOTE VECTOR)) elseif (EQ ELEMENT-TYPE T) then (BQUOTE (AND 
ARRAY (SATISFIES (LAMBDA (X) , (if (OR (NLISTP DIMENSIONS) (if (EVERY DIMENSIONS (FUNCTION (LAMBDA (X)
 (EQ X (QUOTE *))))) then (SETQ DIMENSIONS (LENGTH DIMENSIONS)))) then (BQUOTE (EQ (ARRAY-RANK X) , 
DIMENSIONS)) else (BQUOTE (\ARRAY.DIMENSIONS.MATCH (ARRAY-DIMENSIONS X) (QUOTE , DIMENSIONS)))))))) 
else (HELP "Unimplemented array type designator"))))))))
(PUTDEF (QUOTE VECTOR) (QUOTE TYPES) (QUOTE (DEFTYPE VECTOR (&OPTIONAL (ELEMENT-TYPE (QUOTE *)) (SIZE 
(QUOTE *))) (if (EQ ELEMENT-TYPE (QUOTE *)) then (if (EQ SIZE (QUOTE *)) then (BQUOTE (SATISFIES 
VECTORP)) else (BQUOTE (AND (SATISFIES VECTORP) (SATISFIES (LAMBDA (V) (IEQP (ARRAY-DIMENSION V 0) , 
SIZE)))))) else (BQUOTE (ARRAY , ELEMENT-TYPE (*)))))))

(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
 SIMPLE-STRING)

(PUTPROPS CHARACTER TYPE-COERCE
 CL:CHARACTER)

(PUTPROPS FLOAT TYPE-COERCE
 FLOAT)

(PUTPROPS SIMPLE-STRING TYPE-COERCE
 MKSTRING)

(RPAQ \COERCEMACROHASH
 (HASHARRAY 30))
(DECLARE: EVAL@COMPILE 
(DEFMACRO TYPECASE (KEYFORM &REST FORMS) 
"Type dispatch, order is important, more specific types should appear first" (BQUOTE (LET ((
$$TYPE-VALUE , KEYFORM)) (COND ., (CL:MAPCAR (FUNCTION (LAMBDA (FORM) (LET ((TYPE (CAR FORM)) (FORM (
CDR FORM))) (BQUOTE ((TYPEP $$TYPE-VALUE (QUOTE , TYPE)) ., FORM))))) FORMS)))))
)
(PUTPROPS CMLTYPES COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2572 6070 (COERCE 2582 . 2748) (ENUMERATED-TYPES-OF 2750 . 2885) (TYPE-OF 2887 . 2982) 
(TYPEP 2984 . 3088) (TYPES.GETDEF 3090 . 3579) (\COERCE.FUNCTION 3581 . 4339) (\RANGE.TYPE 4341 . 5015
) (\TYPEP.EXPAND.MACRO 5017 . 5148) (\TYPEP.PRED 5150 . 6068)))))
STOP