(FILECREATED "20-Aug-86 12:53:58" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;50
changes to: (FNS \TYPEP.PRED)
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 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) (* 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))