(FILECREATED " 1-Oct-86 17:20:50" {ERIS}<LISPCORE>SOURCES>CMLTYPES.;4 36511
changes to: (FNS \TYPEP.PRED)
(VARS CMLTYPESCOMS)
(FUNCTIONS EQUALP CL:FLOATP CL:NUMBERP)
(PROPS (HARRAYP CMLTYPE))
(OPTIMIZERS CL:FLOATP CL:NUMBERP)
previous date: "10-Sep-86 17:58:11" {ERIS}<LISPCORE>SOURCES>CMLTYPES.;2)
(* "
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 CL:NUMBERP CL:FLOATP)
(* ; "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 CL:NUMBERP CL:FLOATP)
(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)
(* ;;; "tell the filepkg what to do with the %"deftype%" property")
(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 (* ;; "so that datatypes will be properly compared")
(LET ((TYPENAME (TYPENAME X)))
(AND (EQ TYPENAME (TYPENAME Y))
(LET ((DESCRIPTORS (GETDESCRIPTORS TYPENAME)))
(CL:IF DESCRIPTORS (FOR FIELD IN DESCRIPTORS
ALWAYS (EQUALP (FETCHFIELD FIELD X)
(FETCHFIELD FIELD Y)))))))))))
(* ; "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))))
(DEFOPTIMIZER CL:NUMBERP (X) (BQUOTE (AND (NUMBERP (\, X))
T)))
(DEFOPTIMIZER CL:FLOATP (X) (BQUOTE (AND (FLOATP (\, X))
T)))
(* ; "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) (* gbn " 1-Oct-86 12:37")
(* ;;; "returns the predicate of one argument that determines this type. The result is also cached in clisparray.")
(COND
((LISTP TYPE)
(OR (GETHASH TYPE CLISPARRAY)
(PUTHASH TYPE (CASE (CAR TYPE)
(SATISFIES (CADR TYPE))
(DATATYPE (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 (* ;; "there is no deftype on thie non-list type. ")
(CL:IF (GETFIELDSPECS TYPE)
(PROGN (* ;;
"This is a datatype without a deftype, so install one and warn the user.")
(WARN "Installing DEFTYPE for datatype ~S" TYPE)
(/PUTPROP TYPE (QUOTE DEFTYPE)
(BQUOTE (MACRO NIL (QUOTE (DATATYPE
(\, TYPE)))))))
(PROGN (UNTIL (SETQ PROP (GETPROP TYPE (QUOTE DEFTYPE)))
DO (CERROR "Use the deftype you have specified."
"No type definition for ~S. Specify one with DEFTYPE."
TYPE))))
(\TYPEP.PRED TYPE))))))))))
)
(DEFDEFINER DEFTYPE TYPES (NAME LAMBDA-LIST &BODY BODY)
(BQUOTE (PUTPROPS (\, NAME)
DEFTYPE
(MACRO (\, LAMBDA-LIST)
(\, (MKPROGN BODY))))))
(DEFUN CL:NUMBERP (X) (AND (NUMBERP X)
T))
(DEFUN CL:FLOATP (X) (AND (FLOATP X)
T))
(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-TABLE)
(PUTPROPS TWOD-ARRAY CMLTYPE ARRAY)
(PUTPROPS SYMBOL CMLSUBTYPEDESCRIMINATOR SYMBOL-TYPE)
(PUTPROPS ARRAY CMLSUBTYPEDESCRIMINATOR ARRAY-TYPE)
(* ;;; "tell the filepkg what to do with the %"deftype%" property")
(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 (9351 18741 (ARRAY-TYPE 9361 . 11420) (FALSE 11422 . 11452) (SYMBOL-TYPE 11454 . 11645)
(TRUE 11647 . 11674) (\RANGE.TYPE 11676 . 15149) (\TYPEP.EXPAND.MACRO 15151 . 15345) (\TYPEP.PRED
15347 . 18739)))))
STOP