(FILECREATED " 6-Aug-86 18:37:24" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;49 29284
changes to: (VARS CMLTYPESCOMS)
(FNS \TYPEP.PRED)
previous date: "29-Jul-86 01:52:36" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;47)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLTYPESCOMS)
(RPAQQ CMLTYPESCOMS
((* includes functions for types & most predicates)
(FNS EQL CL:EQUAL EQUALP TYPE-OF)
(COMS (* optimize by constant fold and coerce to EQ where possible)
(PROP BYTEMACRO EQL CL:EQUAL EQUALP))
(FNS FALSE TRUE)
(PROP DMACRO COERCE FALSE TRUE TYPEP)
(FUNCTIONS TYPEP COERCE)
(FNS FALSE TRUE TYPEP)
(FNS \COERCE.FUNCTION \RANGE.TYPE \TYPEP.EXPAND.MACRO \TYPEP.PRED)
(P (MOVD (QUOTE TYPENAMEP)
(QUOTE STRUCTURE-TYPEP)))
(FUNCTIONS DEFTYPE DEFTYPE-PREDICATE)
(DEFINE-TYPES TYPES)
(TYPES CL:ATOM BIGNUM BIT CL:CHARACTER CONS DOUBLE-FLOAT FIXNUM FLOAT HASH-TABLE INTEGER
KEYWORD LIST LONG-FLOAT CL:MEMBER CL:MOD NULL NUMBER SHORT-FLOAT SIGNED-BYTE
STANDARD-CHAR SINGLE-FLOAT SYMBOL UNSIGNED-BYTE RATIONAL COMPLEX SEQUENCE)
(TYPES ARRAY VECTOR SIMPLE-STRING STRING SIMPLE-ARRAY SIMPLE-VECTOR BIT-VECTOR
SIMPLE-BIT-VECTOR)
(* for TYPE-OF - Interlisp types that have different COmmon Lisp names)
(PROP CMLTYPE CHARACTER FIXP FLOATP GENERAL-ARRAY LISTP LITATOM ONED-ARRAY SMALLP STRINGP
HARRAYP TWOD-ARRAY)
(PROP CMLSUBTYPEDESCRIMINATOR SYMBOL ARRAY)
(FNS SYMBOL-TYPE ARRAY-TYPE)
(PROP TYPE-COERCE CL:CHARACTER COMPLEX FLOAT SIMPLE-STRING)
(VARS (\COERCEMACROHASH (HASHARRAY 30)))
(FUNCTIONS TYPECASE)
(PROP FILETYPE CMLTYPES)
(PROP PROPTYPE DEFTYPE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA)))))
(* includes functions for types & most predicates)
(DEFINEQ
(EQL
[LAMBDA (X Y) (* lmm "19-Jun-86 16:11")
(OR (EQ X Y)
(TYPECASE X [INTEGER (TYPECASE Y (INTEGER (IEQP X Y]
[FLOAT (TYPECASE Y (FLOAT (FEQP X Y]
[RATIO (TYPECASE Y (RATIO (AND (EQL (RATIO-NUMERATOR X)
(RATIO-NUMERATOR Y))
(EQL (RATIO-DENOMINATOR X)
(RATIO-DENOMINATOR Y]
(COMPLEX (TYPECASE Y (COMPLEX (AND (EQL (COMPLEX-REALPART X)
(COMPLEX-REALPART Y))
(EQL (COMPLEX-IMAGPART X)
(COMPLEX-IMAGPART Y])
(CL:EQUAL
[LAMBDA (X Y) (* hdj "23-Jul-86 11:42")
(OR (EQL X Y)
(TYPECASE X [CONS (AND (CONSP Y)
(CL:EQUAL (CAR X)
(CAR Y))
(CL:EQUAL (CDR X)
(CDR Y]
(STRING (AND (STRINGP Y)
(STRING= X Y)
T))
(PATHNAME (AND (PATHNAMEP Y)
(%%PATHNAME-EQUAL X Y)))
(T NIL])
(EQUALP
[LAMBDA (X Y) (* lmm "24-Jul-86 03:01")
(OR (EQL X Y)
(TYPECASE X (NUMBER (AND (NUMBERP Y)
(= X Y)))
[CONS (AND (CONSP Y)
(EQUALP (CAR X)
(CAR Y))
(EQUALP (CDR X)
(CDR Y]
(CL:CHARACTER (AND (TYPEP Y (QUOTE CL:CHARACTER))
(CHAR-EQUAL X Y)))
(STRING (AND (TYPEP Y (QUOTE STRING))
(STRING-EQUAL X Y)))
(PATHNAME (AND (PATHNAMEP Y)
(%%PATHNAME-EQUAL X Y)))
[VECTOR (AND (TYPEP Y (QUOTE VECTOR))
(LET [(LENGTH (CL:IF (ARRAY-HAS-FILL-POINTER-P X)
(FILL-POINTER X)
(CL:LENGTH X]
(AND (EQL LENGTH (CL:IF (ARRAY-HAS-FILL-POINTER-P Y)
(FILL-POINTER Y)
(CL:LENGTH Y)))
(DOTIMES (I LENGTH T)
(OR (EQUALP (AREF X I)
(AREF Y I))
(RETURN NIL]
(T NIL])
(TYPE-OF
[LAMBDA (X) (* lmm "18-Jul-86 16:39")
(LET ((TYPE (TYPENAME X)))
(SETQ TYPE (OR (GETPROP TYPE (QUOTE CMLTYPE))
TYPE))
(OR (LET [(D (GETPROP TYPE (QUOTE CMLSUBTYPEDESCRIMINATOR]
(AND D (FUNCALL D X)))
TYPE])
)
(* optimize by constant fold and coerce to EQ where possible)
(PUTPROPS EQL BYTEMACRO COMP.EQ)
(PUTPROPS CL:EQUAL BYTEMACRO COMP.EQ)
(PUTPROPS EQUALP BYTEMACRO COMP.EQ)
(DEFINEQ
(FALSE
[LAMBDA NIL NIL])
(TRUE
[LAMBDA NIL T])
)
(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))) )
)
(PUTPROPS FALSE 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))) )
)
(DEFUN TYPEP (OBJECT TYPE) (AND (FUNCALL (\TYPEP.PRED TYPE)
OBJECT)
T))
(DEFUN COERCE (OBJECT RESULT-TYPE) (COND
((TYPEP OBJECT RESULT-TYPE)
OBJECT)
(T (FUNCALL (OR (\COERCE.FUNCTION RESULT-TYPE)
(RETURN-FROM COERCE
(CL:MAP RESULT-TYPE
(FUNCTION IDENTITY)
OBJECT)))
OBJECT))))
(DEFINEQ
(FALSE
[LAMBDA NIL NIL])
(TRUE
[LAMBDA NIL T])
(TYPEP
[LAMBDA (OBJECT TYPE) (* lmm " 1-Aug-85 12:07")
(AND (FUNCALL (\TYPEP.PRED TYPE)
OBJECT)
T])
)
(DEFINEQ
(\COERCE.FUNCTION
[LAMBDA (TYPE) (* lmm "29-Jul-86 01:30")
(*
"return a coerce function for a given type, if it has one. Used by optimizer"
"and by runtime version of COERCE")
(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)
NIL)
(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)
(CL:ERROR (QUOTE TYPE-MISMATCH)
:VALUE X :NAME "coerce's argument" :MESSAGE
"anything that can coerce to type NIL"])
(GETPROP TYPE (QUOTE TYPE-COERCE])
(\RANGE.TYPE
[LAMBDA (BASETYPE LOW HIGH RANGELIST) (* lmm "18-Jul-86 16:40")
(if (NULL LOW)
then (SETQ LOW (QUOTE CL:*)))
(OR HIGH (SETQ HIGH (QUOTE CL:*)))
(if (AND (EQ LOW (QUOTE CL:*))
(EQ HIGH (QUOTE CL:*)))
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 CL:*))
then (BQUOTE (((\, (if (LISTP LOW)
then (SETQ LOW (CAR LOW))
(QUOTE <)
else (QUOTE <=)))
(\, LOW)
X]
(\,@ (if (NEQ HIGH (QUOTE CL:*))
then (BQUOTE (((\, (if (LISTP HIGH)
then (SETQ HIGH (CAR HIGH))
(QUOTE <)
else (QUOTE <=)))
X
(\, HIGH])
(\TYPEP.EXPAND.MACRO
[LAMBDA (PROP TYPE) (* lmm "18-Jul-86 16:40")
(EXPAND-DEFMACRO (CDR PROP)
TYPE
(QUOTE CL:*])
(\TYPEP.PRED
(LAMBDA (TYPE) (* gbn " 6-Aug-86 02:12")
(if (LISTP TYPE)
then (OR (GETHASH TYPE CLISPARRAY)
(PUTHASH TYPE (SELECTQ (CAR TYPE)
(SATISFIES (CADR TYPE))
(DATATYPE (BQUOTE (OPENLAMBDA (X)
(\INSTANCE-P 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 FALSE))
(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 TYPENAMEP)
(QUOTE STRUCTURE-TYPEP))
(DEFDEFINER DEFTYPE TYPES (NAME LAMBDA-LIST &BODY BODY)
(COND
((LISTP LAMBDA-LIST)
(BQUOTE (PUTPROPS (\, NAME)
DEFTYPE
(MACRO (\, LAMBDA-LIST)
(\, (MKPROGN BODY))))))
(T (BQUOTE (PUTPROPS (\, NAME)
DEFTYPE
(MACRO (\, LAMBDA-LIST)
(\, (MKPROGN BODY))))))))
(DEFDEFINER DEFTYPE-PREDICATE TYPES (NAME PREDICATE)
(BQUOTE (PUTPROPS (\, NAME)
TYPE-PREDICATE
(\, PREDICATE))))
(DEF-DEFINE-TYPE TYPES "Common Lisp type definitions" )
(DEFTYPE CL:ATOM NIL (QUOTE (SATISFIES CL:ATOM)))
(DEFTYPE BIGNUM NIL (QUOTE (OR (DATATYPE FIXP)
(DATATYPE BIGNUM))))
(DEFTYPE BIT NIL (QUOTE (CL:MOD 2)))
(DEFTYPE CL:CHARACTER NIL (QUOTE (SATISFIES CHARACTERP)))
(DEFTYPE CONS NIL (QUOTE (DATATYPE LISTP)))
(DEFTYPE DOUBLE-FLOAT (&REST X) (CONS (QUOTE FLOAT)
X))
(DEFTYPE FIXNUM NIL (QUOTE (DATATYPE SMALLP)))
(DEFTYPE FLOAT (&OPTIONAL LOW HIGH) (\RANGE.TYPE (QUOTE (DATATYPE FLOATP))
LOW HIGH))
(DEFTYPE HASH-TABLE NIL (QUOTE (DATATYPE HARRAYP)))
(DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (\RANGE.TYPE (QUOTE (SATISFIES FIXP))
LOW HIGH (QUOTE ((-65536 65535 FIXNUM)
(0 1 (CL:MEMBER 0 1))))))
(DEFTYPE KEYWORD NIL (QUOTE (SATISFIES KEYWORDP)))
(DEFTYPE LIST (&OPTIONAL TYPE)
(COND
((EQ TYPE (QUOTE CL:*))
(QUOTE (OR NULL CONS)))
(T (BQUOTE (AND LIST (SATISFIES (LAMBDA (X)
(CL:EVERY (CL:FUNCTION (CL:LAMBDA (ELEMENT)
(TYPEP ELEMENT
(QUOTE (\, TYPE)))))
(THE LIST X)))))))))
(DEFTYPE LONG-FLOAT (&REST X) (CONS (QUOTE FLOAT)
X))
(DEFTYPE CL:MEMBER (&REST VALUES) (BQUOTE (SATISFIES (LAMBDA (X)
(CL:MEMBER X (QUOTE (\, VALUES)))))))
(DEFTYPE CL:MOD (N) (BQUOTE (INTEGER 0 (\, (SUB1 N)))))
(DEFTYPE NULL NIL (QUOTE (CL:MEMBER NIL)))
(DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP)))
(DEFTYPE SHORT-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
REST))
(DEFTYPE SIGNED-BYTE (&OPTIONAL S) (if (EQ S (QUOTE CL:*))
then (QUOTE INTEGER)
else (BQUOTE (INTEGER (\, (MINUS (SETQ S (EXPT 2 (SUB1 S)))))
(\, (SUB1 S))))))
(DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES STANDARD-CHAR-P)))
(DEFTYPE SINGLE-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
REST))
(DEFTYPE SYMBOL NIL (QUOTE (DATATYPE LITATOM)))
(DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (if (EQ S (QUOTE CL:*))
then (QUOTE (INTEGER 0))
else (BQUOTE (INTEGER 0 ((\, (EXPT 2 S)))))))
(DEFTYPE RATIONAL NIL (QUOTE (OR RATIO INTEGER)))
(DEFTYPE COMPLEX (&OPTIONAL TYPE) (CL:IF (EQ TYPE (QUOTE CL:*))
(QUOTE (DATATYPE COMPLEX))
(BQUOTE (AND COMPLEX (SATISFIES (LAMBDA (X)
(TYPEP (COMPLEX-REALPART
X)
(QUOTE (\, TYPE))))
)))))
(DEFTYPE SEQUENCE (&OPTIONAL TYPE)
(COND
((EQ TYPE (QUOTE CL:*))
(QUOTE (OR VECTOR LIST)))
(T (BQUOTE (AND SEQUENCE (SATISFIES (LAMBDA (X)
(CL:EVERY (CL:FUNCTION (CL:LAMBDA
(ELEMENT)
(TYPEP ELEMENT
(QUOTE (\, TYPE)))))
X))))))))
(DEFTYPE ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS)
(if (FIXP DIMENSIONS)
then (SETQ DIMENSIONS (for I from 1 to DIMENSIONS collect (QUOTE CL:*))))
(if (NEQ ELEMENT-TYPE (QUOTE CL:*))
then (SETQ ELEMENT-TYPE (\GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))
(if (EQ DIMENSIONS (QUOTE CL:*))
then (if (EQ ELEMENT-TYPE (QUOTE CL:*))
then (QUOTE (SATISFIES CL:ARRAYP))
else (BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:ARRAYP X)
(EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))
elseif (EQUAL DIMENSIONS (QUOTE (CL:*)))
then (if (EQ ELEMENT-TYPE (QUOTE CL:*))
then (QUOTE VECTOR)
elseif (EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
then (QUOTE STRING)
elseif (MEMBER ELEMENT-TYPE (QUOTE (BIT (UNSIGNED-BYTE 1))))
then (QUOTE BIT-VECTOR)
else (BQUOTE (SATISFIES (LAMBDA (X)
(AND (VECTORP X)
(EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))
elseif (EVERY DIMENSIONS (FUNCTION (LAMBDA (X)
(EQ X (QUOTE CL:*)))))
then (BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:ARRAYP X)
(EQL (ARRAY-RANK X)
(\, (LENGTH DIMENSIONS)))
(\,@ (if (NEQ ELEMENT-TYPE (QUOTE CL:*))
then (BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))
)
elseif (EVERY DIMENSIONS (FUNCTION (LAMBDA (X)
(OR (EQ X (QUOTE CL:*))
(FIXP X)))))
then
(if (EQLENGTH DIMENSIONS 1)
then (BQUOTE (STRING (\, (CAR DIMENSIONS))))
else (BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:ARRAYP X)
(EQL (ARRAY-RANK X)
(\, (LENGTH DIMENSIONS)))
(for DIM in (ARRAY-DIMENSIONS X) as DIMSPEC
in (QUOTE (\, DIMENSIONS))
always (OR (EQ DIMSPEC (QUOTE CL:*))
(EQL DIM DIMSPEC)))
(\,@ (if (NEQ ELEMENT-TYPE (QUOTE CL:*))
then (BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))
))))
else (ERROR "Bad (final) array type designator" (BQUOTE (ARRAY %, ELEMENT-TYPE %, DIMENSIONS)))))
(DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE)
(if (EQ ELEMENT-TYPE (QUOTE CL:*))
then (if (EQ SIZE (QUOTE CL:*))
then (BQUOTE (SATISFIES VECTORP))
else (BQUOTE (SATISFIES (LAMBDA (V)
(AND (VECTORP X)
(EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE)))))))
elseif (EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
then (BQUOTE (STRING (\, SIZE)))
elseif (MEMBER ELEMENT-TYPE (QUOTE (BIT (UNSIGNED-BYTE 1)))
NIL)
then (BQUOTE (BIT-VECTOR (\, SIZE)))
else (BQUOTE (SATISFIES (LAMBDA (V)
(AND (VECTORP X)
(EQUAL (ARRAY-ELEMENT-TYPE V)
(\, ELEMENT-TYPE))
(\,@ (if (NEQ SIZE (QUOTE CL:*))
then (BQUOTE ((EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE))))))))))))
(DEFTYPE SIMPLE-STRING (&OPTIONAL SIZE) (if (EQ SIZE (QUOTE CL:*))
then (BQUOTE (SATISFIES SIMPLE-STRING-P))
else (BQUOTE (SATISFIES (LAMBDA (V)
(AND (SIMPLE-STRING-P V)
(EQL (ARRAY-TOTAL-SIZE
V)
(\, SIZE))))))))
(DEFTYPE STRING (&OPTIONAL SIZE) (if (EQ SIZE (QUOTE CL:*))
then (QUOTE (SATISFIES CL:STRINGP))
else (BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:STRINGP X)
(EQL (ARRAY-TOTAL-SIZE X)
(\, SIZE))))))))
(DEFTYPE SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMSPEC)
(if (EQ ELEMENT-TYPE (QUOTE CL:*))
then (if (EQ DIMSPEC (QUOTE CL:*))
then (BQUOTE (SATISFIES SIMPLE-ARRAY-P))
else (BQUOTE (AND (SATISFIES SIMPLE-ARRAY-P)
(ARRAY CL:* (\, DIMSPEC)))))
else (BQUOTE (AND (SATISFIES SIMPLE-ARRAY-P)
(ARRAY (\, ELEMENT-TYPE)
(\, DIMSPEC))))))
(DEFTYPE SIMPLE-VECTOR (&OPTIONAL SIZE) (BQUOTE (AND (SATISFIES SIMPLE-VECTOR-P)
(VECTOR T (\, SIZE)))))
(DEFTYPE BIT-VECTOR (&OPTIONAL SIZE) (if (EQ SIZE (QUOTE CL:*))
then (BQUOTE (SATISFIES BIT-VECTOR-P))
else (BQUOTE (SATISFIES (LAMBDA (V)
(AND (BIT-VECTOR-P V)
(EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE))))))))
(DEFTYPE SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (if (EQ SIZE (QUOTE CL:*))
then (BQUOTE (SATISFIES SIMPLE-BIT-VECTOR-P))
else (BQUOTE (SATISFIES (LAMBDA (V)
(AND (SIMPLE-BIT-VECTOR-P
V)
(EQL (ARRAY-TOTAL-SIZE
V)
(\, SIZE))))))))
(* for TYPE-OF - Interlisp types that have different COmmon Lisp names)
(PUTPROPS CHARACTER CMLTYPE CL:CHARACTER)
(PUTPROPS FIXP CMLTYPE BIGNUM)
(PUTPROPS FLOATP CMLTYPE SINGLE-FLOAT)
(PUTPROPS GENERAL-ARRAY CMLTYPE ARRAY)
(PUTPROPS LISTP CMLTYPE CONS)
(PUTPROPS LITATOM CMLTYPE SYMBOL)
(PUTPROPS ONED-ARRAY CMLTYPE ARRAY)
(PUTPROPS SMALLP CMLTYPE FIXNUM)
(PUTPROPS STRINGP CMLTYPE SIMPLE-STRING)
(PUTPROPS HARRAYP CMLTYPE HASH-ARRAY)
(PUTPROPS TWOD-ARRAY CMLTYPE ARRAY)
(PUTPROPS SYMBOL CMLSUBTYPEDESCRIMINATOR SYMBOL-TYPE)
(PUTPROPS ARRAY CMLSUBTYPEDESCRIMINATOR ARRAY-TYPE)
(DEFINEQ
(SYMBOL-TYPE
[LAMBDA (X) (* lmm " 8-May-86 01:57")
(CL:IF (KEYWORDP X)
(QUOTE KEYWORD)
(QUOTE SYMBOL])
(ARRAY-TYPE
[LAMBDA (ARRAY) (* lmm "21-Jul-86 03:19")
(COND
((STRINGP ARRAY) (* handle interlisp case)
(QUOTE SIMPLE-STRING))
[(\ONED-ARRAY-P ARRAY)
(COND
((fetch (ARRAY-HEADER STRING-P) of ARRAY)
(QUOTE STRING))
(T (LIST (QUOTE VECTOR)
(ARRAY-ELEMENT-TYPE ARRAY]
((\VECTORP ARRAY)
(LIST (QUOTE VECTOR)
(ARRAY-ELEMENT-TYPE ARRAY)))
(T (LIST (QUOTE ARRAY)
(ARRAY-ELEMENT-TYPE ARRAY])
)
(PUTPROPS CL:CHARACTER TYPE-COERCE CL:CHARACTER)
(PUTPROPS COMPLEX TYPE-COERCE COMPLEX)
(PUTPROPS FLOAT TYPE-COERCE FLOAT)
(PUTPROPS SIMPLE-STRING TYPE-COERCE MKSTRING)
(RPAQ \COERCEMACROHASH (HASHARRAY 30))
(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 (CL:IF (EQ (CAR FORM)
(BQUOTE OTHERWISE))
T
(CAR FORM)))
(FORM (CDR FORM)))
(BQUOTE ((TYPEP $$TYPE-VALUE (QUOTE %, TYPE))
., FORM)))))
FORMS)))))
(PUTPROPS CMLTYPES FILETYPE COMPILE-FILE)
(PUTPROPS DEFTYPE PROPTYPE IGNORE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS CMLTYPES COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2198 5561 (EQL 2208 . 3052) (CL:EQUAL 3054 . 3661) (EQUALP 3663 . 5204) (TYPE-OF 5206
. 5559)) (5754 5825 (FALSE 5764 . 5794) (TRUE 5796 . 5823)) (7790 8037 (FALSE 7800 . 7830) (TRUE 7832
. 7859) (TYPEP 7861 . 8035)) (8038 13980 (\COERCE.FUNCTION 8048 . 10020) (\RANGE.TYPE 10022 . 11731)
(\TYPEP.EXPAND.MACRO 11733 . 11925) (\TYPEP.PRED 11927 . 13978)) (27061 27892 (SYMBOL-TYPE 27071 .
27260) (ARRAY-TYPE 27262 . 27890)))))
STOP