(FILECREATED "14-Oct-86 14:38:33" {ERIS}<LISPCORE>SOURCES>CMLARRAY-SUPPORT.;3 29598
changes to: (VARS CMLARRAY-SUPPORTCOMS)
previous date: "21-Sep-86 19:42:35" {ERIS}<LISPCORE>SOURCES>CMLARRAY-SUPPORT.;2)
(* "
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLARRAY-SUPPORTCOMS)
(RPAQQ CMLARRAY-SUPPORTCOMS
((* * "Cmlarray support macros and functions")
(FUNCTIONS %%CHECK-CIRCLE-PRINT %%CHECK-INDICES %%CHECK-NOT-WRITEABLE %%EXPAND-BIT-OP
%%GENERAL-ARRAY-ADJUST-BASE %%GET-ARRAY-OFFSET %%GET-BASE-ARRAY)
(FUNCTIONS %%BIT-TYPE-P %%CHAR-TYPE-P %%CML-TYPE-TO-TYPENUMBER-EXPANDER %%FAT-CHAR-TYPE-P
%%FAT-STRING-CHAR-P %%GET-TYPE-TABLE-ENTRY %%LIT-SIZE-TO-SIZE %%LIT-TYPE-TO-TYPE
%%LLARRAY-MAKE-ACCESSOR-EXPR %%LLARRAY-MAKE-SETTOR-EXPR %%LLARRAY-TYPED-GET
%%LLARRAY-TYPED-PUT %%LLARRAY-TYPEP %%MAKE-ARRAY-TYPE-TABLE %%MAKE-CML-TYPE-TABLE
%%PACK-TYPENUMBER %%SMALLFIXP-SMALLPOSP %%SMALLPOSP-SMALLFIXP %%THIN-CHAR-TYPE-P
%%THIN-STRING-CHAR-P %%TYPE-SIZE-TO-TYPENUMBER %%TYPENUMBER-TO-BITS-PER-ELEMENT
%%TYPENUMBER-TO-CML-TYPE %%TYPENUMBER-TO-DEFAULT-VALUE %%TYPENUMBER-TO-GC-TYPE
%%TYPENUMBER-TO-SIZE %%TYPENUMBER-TO-TYPE \GETBASESMALL-FIXP \GETBASESTRING-CHAR
\GETBASETHINSTRING-CHAR \PUTBASESMALL-FIXP \PUTBASESTRING-CHAR \PUTBASETHINSTRING-CHAR
)
(* * "Describes each entry of \ARRAY-TYPE-TABLE")
(STRUCTURES ARRAY-TABLE-ENTRY)
(* * "These vars contain all the necessary info for typed arrays")
(VARIABLES %%LIT-ARRAY-SIZES %%LIT-ARRAY-TABLE %%LIT-ARRAY-TYPES)
(* * "Tables that drives various macros")
(VARIABLES %%ARRAY-TYPE-TABLE %%CANONICAL-CML-TYPES)
(* * "Constants for (SIGNED-BYTE 16)")
(VARIABLES MAX.SMALLFIXP MIN.SMALLFIXP)
(* * "Constants for STRING-CHARS")
(VARIABLES %%CHAR-TYPE %%BIT-TYPE %%THIN-CHAR-TYPENUMBER %%FAT-CHAR-TYPENUMBER %%MAXTHINCHAR)
(* * "Array data-type numbers")
(VARIABLES %%GENERAL-ARRAY %%ONED-ARRAY %%TWOD-ARRAY)
(* * "Compiler options")
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(PROP FILETYPE CMLARRAY-SUPPORT)))
(* * "Cmlarray support macros and functions")
(DEFMACRO %%CHECK-CIRCLE-PRINT (OBJECT STREAM &REST PRINT-FORMS) "If A has a circle label, print it. If it's not the first time or it has no label, print the contents"
(BQUOTE (LET (CIRCLELABEL FIRSTTIME)
(AND *PRINT-CIRCLE-HASHTABLE* (MULTIPLE-VALUE-SETQ (CIRCLELABEL FIRSTTIME)
(PRINT-CIRCLE-LOOKUP (\, OBJECT))))
(CL:WHEN CIRCLELABEL (.SPACECHECK. (\, STREAM)
(VECTOR-LENGTH CIRCLELABEL))
(WRITE-STRING CIRCLELABEL (\, STREAM))
(CL:WHEN FIRSTTIME (.SPACECHECK. (\, STREAM)
1)
(WRITE-CHAR |\Space (\, STREAM))))
(CL:WHEN (OR (NOT CIRCLELABEL)
FIRSTTIME)
(\,@ PRINT-FORMS)))))
(DEFMACRO %%CHECK-INDICES (ARRAY START-ARG ARGS)
(* *)
(BQUOTE (CL:DO ((I (\, START-ARG)
(1+ I))
(DIM 0 (1+ DIM))
INDEX)
((> I (\, ARGS))
T)
(SETQ INDEX (ARG (\, ARGS)
I))
(CL:IF (OR (< INDEX 0)
(>= INDEX (ARRAY-DIMENSION (\, ARRAY)
DIM)))
(RETURN NIL)))))
(DEFMACRO %%CHECK-NOT-WRITEABLE (ARRAY TYPE-NUMBER NEWVALUE) (BQUOTE (COND
((fetch (ARRAY-HEADER
READ-ONLY-P)
of (\, ARRAY))
(%%MAKE-ARRAY-WRITEABLE
(\, ARRAY)))
((AND (%%THIN-CHAR-TYPE-P
(\, TYPE-NUMBER))
(%%FAT-STRING-CHAR-P
(\, NEWVALUE)))
(%%MAKE-STRING-ARRAY-FAT
(\, ARRAY))))))
(DEFMACRO %%EXPAND-BIT-OP (OP BIT-ARRAY1 BIT-ARRAY2 RESULT-BIT-ARRAY)
(* *)
(BQUOTE (PROGN (CL:IF (NOT (BIT-ARRAY-P (\, BIT-ARRAY1)))
(CL:ERROR "BIT-ARRAY1 not a bit array"))
(CL:IF (NOT (BIT-ARRAY-P (\, BIT-ARRAY2)))
(CL:ERROR "BIT-ARRAY2 not a bit array"))
(CL:IF (NOT (EQUAL-DIMENSIONS-P (\, BIT-ARRAY1)
(\, BIT-ARRAY2)))
(CL:ERROR "Bit-arrays not of same dimensions"))
(COND
((NULL (\, RESULT-BIT-ARRAY))
(SETQ (\, RESULT-BIT-ARRAY)
(MAKE-ARRAY (ARRAY-DIMENSIONS (\, BIT-ARRAY1))
:ELEMENT-TYPE
(QUOTE BIT))))
((EQ (\, RESULT-BIT-ARRAY)
T)
(SETQ (\, RESULT-BIT-ARRAY)
(\, BIT-ARRAY1)))
((NOT (AND (BIT-ARRAY-P (\, RESULT-BIT-ARRAY))
(EQUAL-DIMENSIONS-P (\, BIT-ARRAY1)
(\, RESULT-BIT-ARRAY))))
(CL:ERROR "Illegal result array")))
(\, (ECASE OP ((AND IOR XOR ANDC2 ORC2)
(BQUOTE (OR (EQ (\, BIT-ARRAY1)
(\, RESULT-BIT-ARRAY))
(%%DO-LOGICAL-OP (QUOTE COPY)
(\, BIT-ARRAY1)
(\, RESULT-BIT-ARRAY)))))
((EQV NAND NOR ANDC1 ORC1)
(BQUOTE (%%DO-LOGICAL-OP (QUOTE NOT)
(\, BIT-ARRAY1)
(\, RESULT-BIT-ARRAY))))))
(\, (ECASE OP (AND (BQUOTE (%%DO-LOGICAL-OP (QUOTE AND)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(IOR (BQUOTE (%%DO-LOGICAL-OP (QUOTE OR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(XOR (BQUOTE (%%DO-LOGICAL-OP (QUOTE XOR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(EQV (BQUOTE (%%DO-LOGICAL-OP (QUOTE XOR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(NAND (BQUOTE (%%DO-LOGICAL-OP (QUOTE COR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(NOR (BQUOTE (%%DO-LOGICAL-OP (QUOTE CAND)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(ANDC1 (BQUOTE (%%DO-LOGICAL-OP (QUOTE AND)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(ANDC2 (BQUOTE (%%DO-LOGICAL-OP (QUOTE CAND)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(ORC1 (BQUOTE (%%DO-LOGICAL-OP (QUOTE OR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(ORC2 (BQUOTE (%%DO-LOGICAL-OP (QUOTE COR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))))
(\, RESULT-BIT-ARRAY))))
(DEFMACRO %%GENERAL-ARRAY-ADJUST-BASE (ARRAY ROW-MAJOR-INDEX)
(* *)
(BQUOTE (CL:IF (ffetch (GENERAL-ARRAY INDIRECT-P) of (\, ARRAY))
(LET ((%%OFFSET 0))
(SETQ (\, ARRAY)
(%%GET-BASE-ARRAY (\, ARRAY)
%%OFFSET))
(SETQ (\, ROW-MAJOR-INDEX)
(+ (\, ROW-MAJOR-INDEX)
%%OFFSET))
(CL:IF (NOT (< (\, ROW-MAJOR-INDEX)
(fetch (ARRAY-HEADER TOTAL-SIZE) of (\, ARRAY))))
(CL:ERROR "Row-major-index out of bounds (displaced to adjustable?)"))))))
(DEFMACRO %%GET-ARRAY-OFFSET (ARRAY) (BQUOTE (COND
((OR (%%ONED-ARRAY-P (\, ARRAY))
(%%GENERAL-ARRAY-P (\, ARRAY)))
(fetch (ARRAY-HEADER OFFSET) of (\, ARRAY)))
((%%TWOD-ARRAY-P (\, ARRAY))
0))))
(DEFMACRO %%GET-BASE-ARRAY (ARRAY OFFSET)
(* *)
(BQUOTE (CL:DO ((%%BASE-ARRAY (\, ARRAY)
(fetch (ARRAY-HEADER BASE) of %%BASE-ARRAY)))
((NOT (fetch (ARRAY-HEADER INDIRECT-P) of %%BASE-ARRAY))
%%BASE-ARRAY)
(SETQ (\, OFFSET)
(+ (\, OFFSET)
(%%GET-ARRAY-OFFSET %%BASE-ARRAY))))))
(DEFMACRO %%BIT-TYPE-P (TYPE-NUMBER)
(* *)
(BQUOTE (EQ (\, TYPE-NUMBER)
%%BIT-TYPE)))
(DEFMACRO %%CHAR-TYPE-P (TYPE-NUMBER)
(* *)
(BQUOTE (EQ (%%TYPENUMBER-TO-TYPE (\, TYPE-NUMBER))
%%CHAR-TYPE)))
(DEFMACRO %%CML-TYPE-TO-TYPENUMBER-EXPANDER (CML-TYPE)
(* *)
(LET
((SIMPLE-TYPES (REMOVE T (MAPCAN (CL:FUNCTION (CL:LAMBDA (ENTRY)
(CL:IF (NOT (LISTP (CAR ENTRY)))
(LIST (CAR ENTRY)))))
%%CANONICAL-CML-TYPES)))
(COMPOUND-TYPES (REMOVE-DUPLICATES (MAPCAN (CL:FUNCTION (CL:LAMBDA (ENTRY)
(CL:IF (LISTP (CAR ENTRY))
(LIST (CAAR ENTRY)))))
%%CANONICAL-CML-TYPES))))
(BQUOTE
(CL:IF
(EQ (\, CML-TYPE)
T)
(\, (CADR (CL:ASSOC T %%CANONICAL-CML-TYPES)))
(CL:IF
(LISTP (\, CML-TYPE))
(ECASE
(CAR (\, CML-TYPE))
(\,@
(CL:MAPCAR
(CL:FUNCTION
(CL:LAMBDA (TYPE)
(BQUOTE ((\, TYPE)
(ECASE (CADR (\, CML-TYPE))
(\,@ (MAPCAN (CL:FUNCTION (CL:LAMBDA
(ENTRY)
(CL:IF (AND (LISTP (CAR ENTRY))
(EQ (CAAR ENTRY)
TYPE))
(LIST (LIST (CADAR ENTRY)
(CADR ENTRY))))))
%%CANONICAL-CML-TYPES)))))))
COMPOUND-TYPES)))
(ECASE (\, CML-TYPE)
(\,@ (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPE)
(CL:ASSOC TYPE %%CANONICAL-CML-TYPES)))
SIMPLE-TYPES))))))))
(DEFMACRO %%FAT-CHAR-TYPE-P (TYPE-NUMBER)
(* *)
(BQUOTE (EQ (\, TYPE-NUMBER)
%%FAT-CHAR-TYPENUMBER)))
(DEFMACRO %%FAT-STRING-CHAR-P (OBJECT)
(* *)
(BQUOTE (> (CHAR-CODE (\, OBJECT))
%%MAXTHINCHAR)))
(DEFUN %%GET-TYPE-TABLE-ENTRY (TYPENUMBER)
(* *)
(CADR (CL:ASSOC TYPENUMBER %%ARRAY-TYPE-TABLE)))
(DEFUN %%LIT-SIZE-TO-SIZE (LIT-SIZE)
(* *)
(CADR (CL:ASSOC LIT-SIZE %%LIT-ARRAY-SIZES)))
(DEFUN %%LIT-TYPE-TO-TYPE (LIT-TYPE)
(* *)
(CADR (CL:ASSOC LIT-TYPE %%LIT-ARRAY-TYPES)))
(DEFUN %%LLARRAY-MAKE-ACCESSOR-EXPR (TYPENUMBER BASE OFFSET)
(* *)
(LET* ((ENTRY (%%GET-TYPE-TABLE-ENTRY TYPENUMBER))
(ACCESSOR (ARRAY-TABLE-ENTRY-ACCESSOR ENTRY))
(BITS-PER-ELEMENT (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT ENTRY))
(NEEDS-SHIFT-P (ARRAY-TABLE-ENTRY-NEEDS-SHIFT-P ENTRY)))
(BQUOTE ((\, ACCESSOR)
(\, BASE)
(\, (CL:IF NEEDS-SHIFT-P (BQUOTE (LLSH (\, OFFSET)
(\, NEEDS-SHIFT-P)))
OFFSET))))))
(DEFUN %%LLARRAY-MAKE-SETTOR-EXPR (TYPENUMBER BASE OFFSET NEWVALUE)
(* *)
(LET* ((ENTRY (%%GET-TYPE-TABLE-ENTRY TYPENUMBER))
(SETTOR (ARRAY-TABLE-ENTRY-SETTOR ENTRY))
(BITS-PER-ELEMENT (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT ENTRY))
(NEEDS-SHIFT-P (ARRAY-TABLE-ENTRY-NEEDS-SHIFT-P ENTRY)))
(BQUOTE ((\, SETTOR)
(\, BASE)
(\, (CL:IF NEEDS-SHIFT-P (BQUOTE (LLSH (\, OFFSET)
(\, NEEDS-SHIFT-P)))
OFFSET))
(\, NEWVALUE)))))
(DEFMACRO %%LLARRAY-TYPED-GET (BASE TYPENUMBER OFFSET)
(BQUOTE (ECASE (\, TYPENUMBER)
(\,@ (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPEENTRY)
(BQUOTE ((\, (CAR TYPEENTRY))
(\, (%%LLARRAY-MAKE-ACCESSOR-EXPR
(CAR TYPEENTRY)
BASE OFFSET))))))
%%ARRAY-TYPE-TABLE)))))
(DEFMACRO %%LLARRAY-TYPED-PUT (BASE TYPENUMBER OFFSET NEWVALUE)
(BQUOTE (ECASE (\, TYPENUMBER)
(\,@ (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPEENTRY)
(BQUOTE ((\, (CAR TYPEENTRY))
(\, (%%LLARRAY-MAKE-SETTOR-EXPR
(CAR TYPEENTRY)
BASE OFFSET NEWVALUE))))))
%%ARRAY-TYPE-TABLE)))))
(DEFMACRO %%LLARRAY-TYPEP (TYPENUMBER VALUE)
(BQUOTE (ECASE (\, TYPENUMBER)
(\,@ (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPEENTRY)
(BQUOTE ((\, (CAR TYPEENTRY))
((\, (ARRAY-TABLE-ENTRY-TYPE-TEST
(CADR TYPEENTRY)))
(\, VALUE))))))
%%ARRAY-TYPE-TABLE)))))
(DEFUN %%MAKE-ARRAY-TYPE-TABLE (LIT-TABLE TYPES SIZES)
(* *)
(MAPCAN (CL:FUNCTION (CL:LAMBDA (TYPE-ENTRY)
(LET ((LIT-TYPE (CAR TYPE-ENTRY)))
(CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (SIZE-ENTRY)
(LIST (%%TYPE-SIZE-TO-TYPENUMBER
LIT-TYPE
(CAR SIZE-ENTRY))
(CADR SIZE-ENTRY))))
(CADR TYPE-ENTRY)))))
LIT-TABLE))
(DEFUN %%MAKE-CML-TYPE-TABLE (ARRAY-TABLE)
(* *)
(CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPE-ENTRY)
(LET ((CMLTYPE (ARRAY-TABLE-ENTRY-CML-TYPE (CADR TYPE-ENTRY))))
(LIST CMLTYPE (CAR TYPE-ENTRY)))))
ARRAY-TABLE))
(DEFMACRO %%PACK-TYPENUMBER (ELTTYPE ELTSIZE) (BQUOTE (\ADDBASE (LLSH (\, ELTTYPE)
4)
(\, ELTSIZE))))
(DEFMACRO %%SMALLFIXP-SMALLPOSP (NUM) (BQUOTE (\LOLOC (\, NUM))))
(DEFMACRO %%SMALLPOSP-SMALLFIXP (NUM) (LET ((SYM (GENSYM)))
(BQUOTE (LET (((\, SYM)
(\, NUM)))
(CL:IF (> (\, SYM)
MAX.SMALLFIXP)
(\VAG2 \SmallNegHi (\, SYM))
(\, SYM))))))
(DEFMACRO %%THIN-CHAR-TYPE-P (TYPE-NUMBER)
(* *)
(BQUOTE (EQ (\, TYPE-NUMBER)
%%THIN-CHAR-TYPENUMBER)))
(DEFMACRO %%THIN-STRING-CHAR-P (OBJECT)
(* *)
(BQUOTE (<= (CHAR-CODE (\, OBJECT))
%%MAXTHINCHAR)))
(DEFUN %%TYPE-SIZE-TO-TYPENUMBER (LIT-TYPE LIT-SIZE)
(* *)
(LET ((TYPE (CADR (CL:ASSOC LIT-TYPE %%LIT-ARRAY-TYPES)))
(SIZE (CADR (CL:ASSOC LIT-SIZE %%LIT-ARRAY-SIZES))))
(%%PACK-TYPENUMBER TYPE SIZE)))
(DEFMACRO %%TYPENUMBER-TO-BITS-PER-ELEMENT (TYPE-NUMBER)
(* *)
(BQUOTE (ECASE (\, TYPE-NUMBER)
(\,@ (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPEENTRY)
(BQUOTE ((\, (CAR TYPEENTRY))
(\, (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT
(CADR TYPEENTRY)))))))
%%ARRAY-TYPE-TABLE)))))
(DEFMACRO %%TYPENUMBER-TO-CML-TYPE (TYPE-NUMBER)
(* *)
(BQUOTE (ECASE (\, TYPE-NUMBER)
(\,@ (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPEENTRY)
(BQUOTE ((\, (CAR TYPEENTRY))
(QUOTE (\, (ARRAY-TABLE-ENTRY-CML-TYPE
(CADR TYPEENTRY))))))))
%%ARRAY-TYPE-TABLE)))))
(DEFMACRO %%TYPENUMBER-TO-DEFAULT-VALUE (TYPE-NUMBER)
(* *)
(BQUOTE (ECASE (\, TYPE-NUMBER)
(\,@ (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPEENTRY)
(BQUOTE ((\, (CAR TYPEENTRY))
(\, (ARRAY-TABLE-ENTRY-DEFAULT-VALUE
(CADR TYPEENTRY)))))))
%%ARRAY-TYPE-TABLE)))))
(DEFMACRO %%TYPENUMBER-TO-GC-TYPE (TYPE-NUMBER)
(* *)
(BQUOTE (ECASE (\, TYPE-NUMBER)
(\,@ (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPEENTRY)
(BQUOTE ((\, (CAR TYPEENTRY))
(\, (ARRAY-TABLE-ENTRY-GC-TYPE
(CADR TYPEENTRY)))))))
%%ARRAY-TYPE-TABLE)))))
(DEFMACRO %%TYPENUMBER-TO-SIZE (TYPE-NUMBER) (BQUOTE (LOGAND (\, TYPE-NUMBER)
15)))
(DEFMACRO %%TYPENUMBER-TO-TYPE (TYPE-NUMBER) (BQUOTE (LRSH (\, TYPE-NUMBER)
4)))
(DEFMACRO \GETBASESMALL-FIXP (BASE OFFSET)
(* *)
(BQUOTE (%%SMALLPOSP-SMALLFIXP (\GETBASE (\, BASE)
(\, OFFSET)))))
(DEFMACRO \GETBASESTRING-CHAR (PTR DISP)
(* *)
(BQUOTE (CODE-CHAR (\GETBASE (\, PTR)
(\, DISP)))))
(DEFMACRO \GETBASETHINSTRING-CHAR (PTR DISP)
(* *)
(BQUOTE (CODE-CHAR (\GETBASEBYTE (\, PTR)
(\, DISP)))))
(DEFMACRO \PUTBASESMALL-FIXP (BASE OFFSET VALUE)
(* *)
(BQUOTE (\PUTBASE (\, BASE)
(\, OFFSET)
(%%SMALLFIXP-SMALLPOSP (\, VALUE)))))
(DEFMACRO \PUTBASESTRING-CHAR (PTR DISP CHAR)
(* *)
(BQUOTE (\PUTBASE (\, PTR)
(\, DISP)
(CHAR-CODE (\, CHAR)))))
(DEFMACRO \PUTBASETHINSTRING-CHAR (PTR DISP CHAR)
(* *)
(BQUOTE (\PUTBASEBYTE (\, PTR)
(\, DISP)
(CHAR-CODE (\, CHAR)))))
(* * "Describes each entry of \ARRAY-TYPE-TABLE")
(DEFSTRUCT (ARRAY-TABLE-ENTRY (:TYPE LIST)) CML-TYPE ACCESSOR SETTOR BITS-PER-ELEMENT GC-TYPE
DEFAULT-VALUE NEEDS-SHIFT-P TYPE-TEST)
(* * "These vars contain all the necessary info for typed arrays")
(DEFPARAMETER %%LIT-ARRAY-SIZES (QUOTE ((1BIT 0)
(8BIT 3)
(16BIT 4)
(32BIT 6))) "Size codes" )
(DEFPARAMETER %%LIT-ARRAY-TABLE (QUOTE ((STRING-CHAR ((8BIT (STRING-CHAR \GETBASETHINSTRING-CHAR
\PUTBASETHINSTRING-CHAR 8
UNBOXEDBLOCK.GCT |\Null NIL
(CL:LAMBDA (OBJECT)
(%%THIN-STRING-CHAR-P
OBJECT))))
(16BIT (STRING-CHAR \GETBASESTRING-CHAR
\PUTBASESTRING-CHAR 16
UNBOXEDBLOCK.GCT |\Null NIL
(CL:LAMBDA (OBJECT)
(STRING-CHAR-P OBJECT)))))
)
(T ((32BIT (T \GETBASEPTR \RPLPTR 32 PTRBLOCK.GCT NIL 1
(CL:LAMBDA (OBJECT)
T)))))
(XPOINTER ((32BIT (XPOINTER \GETBASEPTR \PUTBASEPTR 32
UNBOXEDBLOCK.GCT NIL 1 (CL:LAMBDA
(OBJECT)
T)))))
(SINGLE-FLOAT ((32BIT (SINGLE-FLOAT \GETBASEFLOATP
\PUTBASEFLOATP 32
UNBOXEDBLOCK.GCT 0.0 1
(CL:LAMBDA (OBJECT)
(FLOATP OBJECT))))))
(UNSIGNED-BYTE ((1BIT ((UNSIGNED-BYTE 1)
\GETBASEBIT \PUTBASEBIT 1
UNBOXEDBLOCK.GCT 0 NIL
(CL:LAMBDA (OBJECT)
(AND (>= OBJECT 0)
(<= OBJECT 1)))))
(8BIT ((UNSIGNED-BYTE 8)
\GETBASEBYTE \PUTBASEBYTE 8
UNBOXEDBLOCK.GCT 0 NIL
(CL:LAMBDA (OBJECT)
(AND (>= OBJECT 0)
(< OBJECT 256)))))
(16BIT ((UNSIGNED-BYTE 16)
\GETBASE \PUTBASE 16 UNBOXEDBLOCK.GCT
0 NIL (CL:LAMBDA (OBJECT)
(SMALLPOSP OBJECT))))))
(SIGNED-BYTE ((16BIT ((SIGNED-BYTE 16)
\GETBASESMALL-FIXP \PUTBASESMALL-FIXP
16 UNBOXEDBLOCK.GCT 0 NIL
(CL:LAMBDA (OBJECT)
(AND (>= OBJECT MIN.SMALLFIXP)
(<= OBJECT MAX.SMALLFIXP)))
))
(32BIT ((SIGNED-BYTE 32)
\GETBASEFIXP \PUTBASEFIXP 32
UNBOXEDBLOCK.GCT 0 1
(CL:LAMBDA (OBJECT)
(AND (>= OBJECT MIN.FIXP)
(<= OBJECT MAX.FIXP))))))))
) "Fields described by record ARRAY-TYPE-TABLE-ENTRY" )
(DEFPARAMETER %%LIT-ARRAY-TYPES (QUOTE ((UNSIGNED-BYTE 0)
(SIGNED-BYTE 1)
(T 2)
(SINGLE-FLOAT 3)
(STRING-CHAR 4)
(XPOINTER 5))) "Type codes" )
(* * "Tables that drives various macros")
(DEFPARAMETER %%ARRAY-TYPE-TABLE (%%MAKE-ARRAY-TYPE-TABLE %%LIT-ARRAY-TABLE %%LIT-ARRAY-TYPES
%%LIT-ARRAY-SIZES) "Drives various macros" )
(DEFPARAMETER %%CANONICAL-CML-TYPES (%%MAKE-CML-TYPE-TABLE %%ARRAY-TYPE-TABLE) )
(* * "Constants for (SIGNED-BYTE 16)")
(DEFCONSTANT MAX.SMALLFIXP (1- (EXPT 2 15)) )
(DEFCONSTANT MIN.SMALLFIXP (- (EXPT 2 15)) )
(* * "Constants for STRING-CHARS")
(DEFCONSTANT %%CHAR-TYPE (%%LIT-TYPE-TO-TYPE (QUOTE STRING-CHAR)) )
(DEFCONSTANT %%BIT-TYPE (%%TYPE-SIZE-TO-TYPENUMBER (QUOTE UNSIGNED-BYTE)
(QUOTE 1BIT)) )
(DEFCONSTANT %%THIN-CHAR-TYPENUMBER (%%TYPE-SIZE-TO-TYPENUMBER (QUOTE STRING-CHAR)
(QUOTE 8BIT)) )
(DEFCONSTANT %%FAT-CHAR-TYPENUMBER (%%TYPE-SIZE-TO-TYPENUMBER (QUOTE STRING-CHAR)
(QUOTE 16BIT)) )
(DEFCONSTANT %%MAXTHINCHAR (1- (EXPT 2 8)) )
(* * "Array data-type numbers")
(DEFCONSTANT %%GENERAL-ARRAY 16 "General-array-type-number")
(DEFCONSTANT %%ONED-ARRAY 14 "ONED-ARRAY type number")
(DEFCONSTANT %%TWOD-ARRAY 15 "TWOD-ARRAY type number")
(* * "Compiler options")
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS CMLARRAY-SUPPORT FILETYPE COMPILE-FILE)
(PUTPROPS CMLARRAY-SUPPORT COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP