(FILECREATED "20-Aug-86 12:57:19" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;51 29418
changes to: (FNS \TYPEP.PRED)
(VARS CMLTYPESCOMS)
previous date: " 6-Aug-86 18:37:24" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;49)
(* 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)
(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])
)
(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) (* lmm "18-Mar-86 18:25")
(if (LISTP TYPE)
then (OR (GETHASH TYPE CLISPARRAY)
(PUTHASH TYPE [SELECTQ (CAR TYPE)
(SATISFIES (CADR TYPE))
(* (\INSTANCE-P NIL (QUOTE SYMBOL))
incorrectly returns NIL
[DATATYPE (BQUOTE (OPENLAMBDA (X)
(\INSTANCE-P
X
(QUOTE (\, (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 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 (2189 5552 (EQL 2199 . 3043) (CL:EQUAL 3045 . 3652) (EQUALP 3654 . 5195) (TYPE-OF 5197
. 5550)) (5745 5816 (FALSE 5755 . 5785) (TRUE 5787 . 5814)) (7781 7852 (FALSE 7791 . 7821) (TRUE 7823
. 7850)) (7853 14114 (\COERCE.FUNCTION 7863 . 9835) (\RANGE.TYPE 9837 . 11546) (\TYPEP.EXPAND.MACRO
11548 . 11740) (\TYPEP.PRED 11742 . 14112)) (27195 28026 (SYMBOL-TYPE 27205 . 27394) (ARRAY-TYPE 27396
. 28024)))))
STOP