(FILECREATED "10-Sep-86 17:58:11" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;61 34410
changes to: (TYPES ARRAY VECTOR SIMPLE-ARRAY)
previous date: " 8-Sep-86 15:17:31" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;60)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLTYPESCOMS)
(RPAQQ CMLTYPESCOMS
((* * Predicates)
(FUNCTIONS CL:EQUAL EQUALP)
(* EQL is now in the init)
(* * Typep and friends)
(FUNCTIONS COERCE TYPECASE TYPEP TYPE-OF)
(* * Optimizers)
(OPTIMIZERS COERCE FALSE TRUE TYPEP)
(* Optimize by constant fold and coerce to EQ where possible)
(PROP BYTEMACRO CL:EQUAL EQUALP)
(* * Support functions)
(FNS ARRAY-TYPE FALSE SYMBOL-TYPE TRUE \RANGE.TYPE \TYPEP.EXPAND.MACRO \TYPEP.PRED)
(FUNCTIONS DEFTYPE)
(DEFINE-TYPES TYPES)
(* * For TYPEP)
(TYPES CL:ATOM BIGNUM BIT CL:CHARACTER CONS DOUBLE-FLOAT FIXNUM FLOAT FUNCTION HASH-TABLE
INTEGER KEYWORD LIST LONG-FLOAT CL:MEMBER CL:MOD NULL NUMBER PACKAGE SHORT-FLOAT
SIGNED-BYTE STANDARD-CHAR STRING-CHAR SINGLE-FLOAT SYMBOL UNSIGNED-BYTE RATIONAL
READTABLE COMMON COMPILED-FUNCTION COMPLEX SEQUENCE)
(* * Array Types)
(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)
(* * What's this for?)
(COMS (PROP PROPTYPE DEFTYPE))
(* * Compiler options)
(PROP FILETYPE CMLTYPES)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA)))))
(* * Predicates)
(DEFUN CL:EQUAL (X Y)
(OR (EQL X Y)
(TYPECASE X (CONS (AND (CONSP Y)
(CL:EQUAL (CAR X)
(CAR Y))
(CL:EQUAL (CDR X)
(CDR Y))))
(STRING (AND (CL:STRINGP Y)
(STRING= X Y)))
(BIT-VECTOR (AND (BIT-VECTOR-P Y)
(LET ((SX (CL:LENGTH X)))
(AND (EQL SX (CL:LENGTH Y))
(DOTIMES (I SX T)
(CL:IF (NOT (EQ (BIT X I)
(BIT Y I)))
(RETURN NIL)))))))
(PATHNAME (AND (PATHNAMEP Y)
(%%PATHNAME-EQUAL X Y)))
(T NIL))))
(DEFUN EQUALP (X Y)
(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 (CHARACTERP Y)
(CHAR-EQUAL X Y)))
(STRING (AND (CL:STRINGP Y)
(STRING-EQUAL X Y)))
(PATHNAME (AND (PATHNAMEP Y)
(%%PATHNAME-EQUAL X Y)))
(VECTOR (AND (VECTORP Y)
(LET ((SX (CL:LENGTH X)))
(AND (EQL SX (CL:LENGTH Y))
(DOTIMES (I SX T)
(CL:IF (NOT (EQUALP (AREF X I)
(AREF Y I)))
(RETURN NIL)))))))
(ARRAY (AND (CL:ARRAYP Y)
(CL:EQUAL (ARRAY-DIMENSIONS X)
(ARRAY-DIMENSIONS Y))
(LET ((FX (\FLATTEN-ARRAY X))
(FY (\FLATTEN-ARRAY Y)))
(DOTIMES (I (ARRAY-TOTAL-SIZE X)
T)
(CL:IF (NOT (EQUALP (AREF FX I)
(AREF FY I)))
(RETURN NIL))))))
(T NIL))))
(* EQL is now in the init)
(* * Typep and friends)
(DEFUN COERCE (OBJECT RESULT-TYPE) "Coerce object to result-type if possible"
(COND
((EQ RESULT-TYPE T)
OBJECT)
((EQ RESULT-TYPE (QUOTE CL:CHARACTER))
(CL:CHARACTER OBJECT))
((CL:MEMBER RESULT-TYPE (QUOTE (FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)))
(FLOAT OBJECT))
((EQ RESULT-TYPE (QUOTE COMPLEX))
(CL:IF (COMPLEXP OBJECT)
OBJECT
(COMPLEX OBJECT)))
((TYPEP OBJECT (QUOTE SEQUENCE))
(CL:MAP RESULT-TYPE (QUOTE IDENTITY)
OBJECT))
(T (CL:ERROR "Cannot coerce to type: ~S" RESULT-TYPE))))
(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)))))
(DEFUN TYPEP (OBJECT TYPE) "Check if OBJECT is of type TYPE" (AND (FUNCALL (\TYPEP.PRED TYPE)
OBJECT)
T))
(DEFUN TYPE-OF (X) (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)))
(* * Optimizers)
(DEFOPTIMIZER COERCE (OBJECT RESULT-TYPE) "Open code the simple coerce cases"
(LET ((CE (CAR (CONSTANTEXPRESSIONP RESULT-TYPE))))
(COND
((EQ CE T)
OBJECT)
((EQ CE (QUOTE CL:CHARACTER))
(BQUOTE (CL:CHARACTER (\, OBJECT))))
((EQ CE (QUOTE COMPLEX))
(BQUOTE (CL:IF (COMPLEXP (\, OBJECT))
(\, OBJECT)
(COMPLEX (\, OBJECT)))))
((CL:MEMBER CE (QUOTE (FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)))
(BQUOTE (FLOAT (\, OBJECT))))
(T (QUOTE COMPILER:PASS)))))
(DEFOPTIMIZER FALSE (&BODY FORMS) (BQUOTE (PROG1 NIL (\,@ FORMS))))
(DEFOPTIMIZER TRUE (&BODY FORMS) (BQUOTE (PROG1 T (\,@ FORMS))))
(DEFOPTIMIZER TYPEP (OBJ TYPESPEC) (LET ((CE (CONSTANTEXPRESSIONP TYPESPEC)))
(CL:IF CE (BQUOTE (AND ((\, (\TYPEP.PRED (CAR CE)))
(\, OBJ))
T))
(QUOTE COMPILER:PASS))))
(* Optimize by constant fold and coerce to EQ where possible)
(PUTPROPS CL:EQUAL BYTEMACRO COMP.EQ)
(PUTPROPS EQUALP BYTEMACRO COMP.EQ)
(* * Support functions)
(DEFINEQ
(ARRAY-TYPE
(LAMBDA (ARRAY) (* lmm "21-Jul-86 03:19")
(LET ((RANK (ARRAY-RANK ARRAY)))
(CL:IF (SIMPLE-ARRAY-P ARRAY)
(CL:IF (EQL 1 RANK)
(LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY)))
(COND
((SIMPLE-STRING-P ARRAY)
(LIST (QUOTE SIMPLE-STRING)
SIZE))
((SIMPLE-BIT-VECTOR-P ARRAY)
(LIST (QUOTE SIMPLE-BIT-VECTOR)
SIZE))
(T (LET ((A-ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY)))
(CL:IF (EQ A-ELT-TYPE T)
(LIST (QUOTE SIMPLE-VECTOR)
SIZE)
(LIST (QUOTE SIMPLE-ARRAY)
A-ELT-TYPE
(LIST SIZE)))))))
(LIST (QUOTE SIMPLE-ARRAY)
(ARRAY-ELEMENT-TYPE ARRAY)
(ARRAY-DIMENSIONS ARRAY)))
(CL:IF (EQL 1 RANK)
(LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY)))
(COND
((CL:STRINGP ARRAY)
(LIST (QUOTE STRING)
SIZE))
((BIT-VECTOR-P ARRAY)
(LIST (QUOTE BIT-VECTOR)
SIZE))
(T (LIST (QUOTE VECTOR)
(ARRAY-ELEMENT-TYPE ARRAY)
SIZE))))
(LIST (QUOTE ARRAY)
(ARRAY-ELEMENT-TYPE ARRAY)
(ARRAY-DIMENSIONS ARRAY)))))))
(FALSE
(LAMBDA NIL NIL))
(SYMBOL-TYPE
(LAMBDA (X) (* lmm " 8-May-86 01:57")
(CL:IF (KEYWORDP X)
(QUOTE KEYWORD)
(QUOTE SYMBOL))))
(TRUE
(LAMBDA NIL T))
(\RANGE.TYPE
(LAMBDA (BASETYPE LOW HIGH RANGELIST) (* Pavel " 2-Sep-86 19:26")
(OR LOW (SETQ LOW (QUOTE CL:*)))
(OR HIGH (SETQ HIGH (QUOTE CL:*)))
(COND
((AND (EQ LOW (QUOTE CL:*))
(EQ HIGH (QUOTE CL:*)))
BASETYPE)
((OR (EQ LOW (QUOTE CL:*))
(EQ HIGH (QUOTE CL:*)))
(BQUOTE (AND (\, BASETYPE)
(SATISFIES (LAMBDA (X)
(AND (\,@ (CL:IF (NOT (EQ LOW (QUOTE CL:*)))
(BQUOTE (((\, (COND
((LISTP LOW)
(SETQ LOW (CAR LOW))
(QUOTE <))
(T (QUOTE <=))))
(\, LOW)
X)))))
(\,@ (CL:IF (NOT (EQ HIGH (QUOTE CL:*)))
(BQUOTE (((\, (COND
((LISTP HIGH)
(SETQ HIGH (CAR HIGH))
(QUOTE <))
(T (QUOTE <=))))
X
(\, HIGH))))))))))))
(T (DOLIST (X RANGELIST (BQUOTE (AND (\, BASETYPE)
(SATISFIES (LAMBDA (X)
(AND ((\, (COND
((LISTP LOW)
(SETQ LOW (CAR LOW))
(QUOTE <))
(T (QUOTE <=))))
(\, LOW)
X)
((\, (COND
((LISTP HIGH)
(SETQ HIGH (CAR HIGH))
(QUOTE <))
(T (QUOTE <=))))
X
(\, HIGH))))))))
(CL:IF (AND (EQUAL LOW (CAR X))
(EQUAL HIGH (CADR X)))
(RETURN (CADDR X)))
(CL:IF (<= (CAR X)
(CL:IF (CONSP LOW)
(1+ (CAR LOW))
LOW)
(CL:IF (CONSP HIGH)
(1- (CAR HIGH))
HIGH)
(CADR X))
(SETQ BASETYPE (CADDR X))))))))
(\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")
(COND
((LISTP TYPE)
(OR (GETHASH TYPE CLISPARRAY)
(PUTHASH TYPE (CASE (CAR TYPE)
(SATISFIES (CADR TYPE))
(DATATYPE
(* (\INSTANCE-P NIL (QUOTE SYMBOL)) incorrectly returns NIL
(DATATYPE (BQUOTE (OPENLAMBDA (X) (\INSTANCE-P X
(QUOTE (\, (CADR TYPE))))))))
(BQUOTE (OPENLAMBDA (X)
(TYPENAMEP X (QUOTE (\, (CADR TYPE)))))))
((AND OR NOT)
(BQUOTE (OPENLAMBDA (X)
((\, (CAR TYPE))
(\,@ (CL:MAPCAR (FUNCTION (LAMBDA (PRED)
(LIST (\TYPEP.PRED
PRED)
(QUOTE X))))
(CDR TYPE)))))))
(OTHERWISE (LET ((PROP (GETPROP (CAR TYPE)
(QUOTE DEFTYPE))))
(CL:IF (EQ (CAR PROP)
(QUOTE MACRO))
(\TYPEP.PRED (\TYPEP.EXPAND.MACRO PROP TYPE))
(CL:ERROR "undefined type used in TYPEP: ~S"
TYPE NIL)))))
CLISPARRAY)))
(T (COND
((EQ TYPE T)
(QUOTE TRUE))
((EQ TYPE NIL)
(QUOTE FALSE))
(T (LET ((PROP (GETPROP TYPE (QUOTE DEFTYPE))))
(CL:IF (EQ (CAR PROP)
(QUOTE 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))))))))))
)
(DEFDEFINER DEFTYPE TYPES (NAME LAMBDA-LIST &BODY BODY)
(BQUOTE (PUTPROPS (\, NAME)
DEFTYPE
(MACRO (\, LAMBDA-LIST)
(\, (MKPROGN BODY))))))
(DEF-DEFINE-TYPE TYPES "Common Lisp type definitions" )
(* * For TYPEP)
(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 FUNCTION NIL (QUOTE (SATISFIES FUNCTIONP)))
(DEFTYPE HASH-TABLE NIL (QUOTE (DATATYPE HARRAYP)))
(DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (\RANGE.TYPE (QUOTE (SATISFIES INTEGERP))
LOW HIGH (QUOTE ((-65536 65535 FIXNUM)
(0 1 (CL:MEMBER 0 1))))))
(DEFTYPE KEYWORD NIL (QUOTE (SATISFIES KEYWORDP)))
(DEFTYPE LIST (&OPTIONAL TYPE)
(CL:IF (EQ TYPE (QUOTE CL:*))
(QUOTE (OR NULL CONS))
(BQUOTE (AND LIST (SATISFIES (LAMBDA (X)
(CL:EVERY (CL:FUNCTION (CL:LAMBDA (ELEMENT)
(TYPEP ELEMENT
(QUOTE (\, TYPE)))))
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 (\, (1- N)))))
(DEFTYPE NULL NIL (QUOTE (SATISFIES NULL)))
(DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP)))
(DEFTYPE PACKAGE NIL (QUOTE (DATATYPE PACKAGE)))
(DEFTYPE SHORT-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
REST))
(DEFTYPE SIGNED-BYTE (&OPTIONAL S) (CL:IF (EQ S (QUOTE CL:*))
(QUOTE INTEGER)
(LET ((SIZE (CL:EXPT 2 (1- S))))
(BQUOTE (INTEGER (\, (- S))
(\, (1- S)))))))
(DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES STANDARD-CHAR-P)))
(DEFTYPE STRING-CHAR NIL (QUOTE (SATISFIES STRING-CHAR-P)))
(DEFTYPE SINGLE-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
REST))
(DEFTYPE SYMBOL NIL (QUOTE (DATATYPE LITATOM)))
(DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (CL:IF (EQ S (QUOTE CL:*))
(QUOTE (INTEGER 0))
(BQUOTE (INTEGER 0 ((\, (CL:EXPT 2 S)))))))
(DEFTYPE RATIONAL NIL (QUOTE (OR RATIO INTEGER)))
(DEFTYPE READTABLE NIL (QUOTE (DATATYPE READTABLEP)))
(DEFTYPE COMMON T)
(DEFTYPE COMPILED-FUNCTION NIL (QUOTE (SATISFIES COMPILED-FUNCTION-P)))
(DEFTYPE COMPLEX (&OPTIONAL TYPE) (CL:IF (EQ TYPE (QUOTE CL:*))
(QUOTE (DATATYPE COMPLEX))
(BQUOTE (AND COMPLEX
(SATISFIES (LAMBDA (X)
(AND (TYPEP (COMPLEX-REALPART
X)
(QUOTE (\, TYPE)))
(TYPEP (COMPLEX-IMAGPART
X)
(QUOTE (\, TYPE)))))))
)))
(DEFTYPE SEQUENCE (&OPTIONAL TYPE)
(CL:IF (EQ TYPE (QUOTE CL:*))
(QUOTE (OR VECTOR LIST))
(BQUOTE (AND SEQUENCE (SATISFIES (LAMBDA (X)
(CL:EVERY (CL:FUNCTION (CL:LAMBDA
(ELEMENT)
(TYPEP ELEMENT
(QUOTE (\, TYPE)))))
X)))))))
(* * Array Types)
(DEFTYPE ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS)
(CL:IF (TYPEP DIMENSIONS (QUOTE FIXNUM))
(SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE CL:*))))
(CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(SETQ ELEMENT-TYPE (%%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))
(COND
((EQ DIMENSIONS (QUOTE CL:*))
(CL:IF (EQ ELEMENT-TYPE (QUOTE CL:*))
(QUOTE (SATISFIES CL:ARRAYP))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:ARRAYP X)
(EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE)))))))))
((EQUAL DIMENSIONS (QUOTE (CL:*)))
(COND
((EQ ELEMENT-TYPE (QUOTE CL:*))
(QUOTE VECTOR))
((EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
(QUOTE STRING))
((OR (EQ ELEMENT-TYPE (QUOTE BIT))
(EQUAL ELEMENT-TYPE (QUOTE (UNSIGNED-BYTE 1))))
(QUOTE BIT-VECTOR))
(T (BQUOTE (SATISFIES (LAMBDA (X)
(AND (VECTORP X)
(EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))
((DOLIST (DIM DIMENSIONS T)
(CL:IF (NOT (EQ DIM (QUOTE CL:*)))
(RETURN NIL)))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:ARRAYP X)
(EQL (ARRAY-RANK X)
(\, (CL:LENGTH DIMENSIONS)))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))))
((DOLIST (DIM DIMENSIONS T)
(CL:IF (NOT (OR (EQ DIM (QUOTE CL:*))
(TYPEP DIM (QUOTE FIXNUM))))
(RETURN NIL)))
(CL:IF (EQL (CL:LENGTH DIMENSIONS 1))
(BQUOTE (VECTOR (\, (CAR DIMENSIONS))))
(BQUOTE (SATISFIES
(LAMBDA (X)
(AND (CL:ARRAYP X)
(EQL (ARRAY-RANK X)
(\, (CL:LENGTH DIMENSIONS)))
(\,@ (CL:DO ((DIMSPEC DIMENSIONS (CDR DIMSPEC))
(DIM 0 (1+ DIM))
FORMS)
((NULL DIMSPEC)
FORMS)
(CL:IF (NOT (EQL (CAR DIMSPEC)
(QUOTE CL:*)))
(CL:PUSH (BQUOTE (EQL (ARRAY-DIMENSION X
(\, DIM))
(\, (CAR DIMSPEC))))
FORMS))))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE)))))))))))))
(T (CL:ERROR "Bad (final) array type designator: ~S" (BQUOTE (ARRAY (\, ELEMENT-TYPE)
(\, DIMENSIONS)))))))
(DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE)
(COND
((EQ ELEMENT-TYPE (QUOTE CL:*))
(CL:IF (EQ SIZE (QUOTE CL:*))
(QUOTE (SATISFIES VECTORP))
(BQUOTE (SATISFIES (LAMBDA (V)
(AND (VECTORP V)
(EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE))))))))
((EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
(BQUOTE (STRING (\, SIZE))))
((MEMBER ELEMENT-TYPE (QUOTE (BIT (UNSIGNED-BYTE 1))))
(BQUOTE (BIT-VECTOR (\, SIZE))))
(T (BQUOTE (SATISFIES (LAMBDA (V)
(AND (VECTORP V)
(EQUAL (ARRAY-ELEMENT-TYPE V)
(QUOTE (\, (%%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))))
(\,@ (CL:IF (NOT (EQ SIZE (QUOTE CL:*)))
(BQUOTE ((EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE)))))))))))))
(DEFTYPE SIMPLE-STRING (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(BQUOTE (SATISFIES SIMPLE-STRING-P))
(BQUOTE (SATISFIES (LAMBDA (V)
(AND (SIMPLE-STRING-P V)
(EQL (ARRAY-TOTAL-SIZE
V)
(\, SIZE))))))))
(DEFTYPE STRING (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(QUOTE (SATISFIES CL:STRINGP))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:STRINGP X)
(EQL (ARRAY-TOTAL-SIZE X)
(\, SIZE))))))))
(DEFTYPE SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) "Simple-array type expander"
(CL:IF (TYPEP DIMENSIONS (QUOTE FIXNUM))
(SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE CL:*))))
(CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(SETQ ELEMENT-TYPE (%%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))
(COND
((EQ DIMENSIONS (QUOTE CL:*))
(CL:IF (EQ ELEMENT-TYPE (QUOTE CL:*))
(QUOTE (SATISFIES SIMPLE-ARRAY-P))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (SIMPLE-ARRAY-P X)
(EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE)))))))))
((EQUAL DIMENSIONS (QUOTE (CL:*)))
(COND
((EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
(QUOTE SIMPLE-STRING))
((OR (EQ ELEMENT-TYPE (QUOTE BIT))
(EQUAL ELEMENT-TYPE (QUOTE (UNSIGNED-BYTE 1))))
(QUOTE SIMPLE-BIT-VECTOR))
((EQ ELEMENT-TYPE T)
(QUOTE SIMPLE-VECTOR))
(T (BQUOTE (SATISFIES (LAMBDA (X)
(AND (SIMPLE-ARRAY-P X)
(EQL 1 (ARRAY-RANK X))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE)))))))))))
)))
((DOLIST (DIM DIMENSIONS T)
(CL:IF (NOT (EQ DIM (QUOTE CL:*)))
(RETURN NIL)))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (SIMPLE-ARRAY-P X)
(EQL (ARRAY-RANK X)
(\, (CL:LENGTH DIMENSIONS)))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))))
((DOLIST (DIM DIMENSIONS T)
(CL:IF (NOT (OR (EQ DIM (QUOTE CL:*))
(TYPEP DIM (QUOTE FIXNUM))))
(RETURN NIL)))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (SIMPLE-ARRAY-P X)
(EQL (ARRAY-RANK X)
(\, (CL:LENGTH DIMENSIONS)))
(\,@ (CL:DO ((DIMSPEC DIMENSIONS (CDR DIMSPEC))
(DIM 0 (1+ DIM))
FORMS)
((NULL DIMSPEC)
FORMS)
(CL:IF (NOT (EQL (CAR DIMSPEC)
(QUOTE CL:*)))
(CL:PUSH (BQUOTE (EQL (ARRAY-DIMENSION
X
(\, DIM))
(\, (CAR DIMSPEC))))
FORMS))))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))))
(T (CL:ERROR "Bad (final) array type designator: ~S" (BQUOTE (SIMPLE-ARRAY (\, ELEMENT-TYPE)
(\, DIMENSIONS)))))))
(DEFTYPE SIMPLE-VECTOR (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(BQUOTE (SATISFIES SIMPLE-VECTOR-P))
(BQUOTE (SATISFIES (LAMBDA (V)
(AND (SIMPLE-VECTOR-P V)
(EQL (ARRAY-TOTAL-SIZE
V)
(\, SIZE))))))))
(DEFTYPE BIT-VECTOR (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(BQUOTE (SATISFIES BIT-VECTOR-P))
(BQUOTE (SATISFIES (LAMBDA (V)
(AND (BIT-VECTOR-P V)
(EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE))))))))
(DEFTYPE SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(BQUOTE (SATISFIES SIMPLE-BIT-VECTOR-P))
(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)
(* * What's this for?)
(PUTPROPS DEFTYPE PROPTYPE IGNORE)
(* * Compiler options)
(PUTPROPS CMLTYPES FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS CMLTYPES COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (8250 16858 (ARRAY-TYPE 8260 . 10319) (FALSE 10321 . 10351) (SYMBOL-TYPE 10353 . 10544)
(TRUE 10546 . 10573) (\RANGE.TYPE 10575 . 14048) (\TYPEP.EXPAND.MACRO 14050 . 14244) (\TYPEP.PRED
14246 . 16856)))))
STOP