initial checkin for sources
This commit is contained in:
Larry Masinter
726
sources/CMLARRAY-SUPPORT
Normal file
726
sources/CMLARRAY-SUPPORT
Normal file
@@ -0,0 +1,726 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(FILECREATED " 2-May-99 14:57:41" |{DSK}<lispcore>sources>CMLARRAY-SUPPORT.;2| 32231
|
||||
|
||||
|changes| |to:| (RECORDS TWOD-ARRAY)
|
||||
|
||||
|previous| |date:| "15-Sep-94 11:10:20" |{DSK}<lispcore>sources>CMLARRAY-SUPPORT.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1986, 1990, 1992, 1994, 1999 by Venue & Xerox Corporation. All rights reserved.
|
||||
|
||||
(PRETTYCOMPRINT CMLARRAY-SUPPORTCOMS)
|
||||
|
||||
(RPAQQ CMLARRAY-SUPPORTCOMS
|
||||
(
|
||||
(* |;;| "Record def's")
|
||||
|
||||
(RECORDS ARRAY-HEADER GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
|
||||
|
||||
(* |;;| "Cmlarray support macros and functions")
|
||||
|
||||
(* \; "Fast predicates")
|
||||
(FUNCTIONS %ARRAYP %SIMPLE-ARRAY-P %SIMPLE-STRING-P %STRINGP %VECTORP)
|
||||
(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)))
|
||||
|
||||
|
||||
|
||||
(* |;;| "Record def's")
|
||||
|
||||
(DECLARE\: EVAL@COMPILE
|
||||
|
||||
(BLOCKRECORD ARRAY-HEADER (
|
||||
(* |;;| "Describes common slots of all array headers. Used when the code can't tell what kind of array it has.")
|
||||
|
||||
(NIL BITS 4) (* \; "First 8 bits are unused")
|
||||
(BASE POINTER) (* \;
|
||||
"24 bits of pointer. Points at raw storage or, in the indirect case, at another array header")
|
||||
(* \; "8 bits of flags")
|
||||
(READ-ONLY-P FLAG) (* \;
|
||||
"Used for headers pointing at symbols pnames")
|
||||
(INDIRECT-P FLAG) (* \;
|
||||
"Points at an array header rather than a raw storage block")
|
||||
(BIT-P FLAG) (* \; "Is a bit array")
|
||||
(STRING-P FLAG) (* \;
|
||||
"Is a string (implies is a vector)")
|
||||
(* \;
|
||||
"If any of the following flags are set, the array in non-simple")
|
||||
(ADJUSTABLE-P FLAG)
|
||||
(DISPLACED-P FLAG)
|
||||
(FILL-POINTER-P FLAG)
|
||||
(EXTENDABLE-P FLAG)
|
||||
(TYPE-NUMBER BITS 8) (* \; "8 bits of type + size")
|
||||
(OFFSET WORD) (* \; "For oned and general arrays")
|
||||
(FILL-POINTER FIXP) (* \; "For oned and general arrays")
|
||||
(TOTAL-SIZE FIXP))
|
||||
(BLOCKRECORD ARRAY-HEADER ((NIL POINTER)
|
||||
(FLAGS BITS 8)
|
||||
(TYPE BITS 4)
|
||||
(SIZE BITS 4)))
|
||||
(ACCESSFNS (SIMPLE-P (EQ 0 (LOGAND (|fetch| (ARRAY-HEADER FLAGS)
|
||||
|of| DATUM)
|
||||
15))))
|
||||
(SYSTEM))
|
||||
|
||||
(DATATYPE GENERAL-ARRAY ((NIL BITS 4) (* \; "For alignment")
|
||||
(STORAGE POINTER) (* \; "24 bits of pointer")
|
||||
(READ-ONLY-P FLAG) (* \; "8 bits of flags")
|
||||
(INDIRECT-P FLAG)
|
||||
(BIT-P FLAG)
|
||||
(STRING-P FLAG)
|
||||
(ADJUSTABLE-P FLAG)
|
||||
(DISPLACED-P FLAG)
|
||||
(FILL-POINTER-P FLAG)
|
||||
(EXTENDABLE-P FLAG)
|
||||
(TYPE-NUMBER BITS 8) (* \; "8 bits of typenumber")
|
||||
(OFFSET WORD)
|
||||
(FILL-POINTER FIXP) (* \;
|
||||
"As of 2.1, these 2 fields are fixp's.")
|
||||
(TOTAL-SIZE FIXP)
|
||||
(DIMS POINTER)))
|
||||
|
||||
(DATATYPE ONED-ARRAY ((NIL BITS 4) (* \; "Don't use high 8 bits")
|
||||
(BASE POINTER) (* \; "The raw storage base")
|
||||
(READ-ONLY-P FLAG) (* \; "8 bits worth of flags")
|
||||
(NIL BITS 1) (* \;
|
||||
"Oned array's cann't be indirect")
|
||||
(BIT-P FLAG)
|
||||
(STRING-P FLAG)
|
||||
(NIL BITS 1) (* \;
|
||||
"Oned-array's cann't be adjustable")
|
||||
(DISPLACED-P FLAG)
|
||||
(FILL-POINTER-P FLAG)
|
||||
(EXTENDABLE-P FLAG)
|
||||
(TYPE-NUMBER BITS 8) (* \;
|
||||
"4 bits of type and 4 bits of size")
|
||||
(OFFSET WORD) (* \; "For displaced arrays")
|
||||
(FILL-POINTER FIXP) (* \; "For filled arrays")
|
||||
(TOTAL-SIZE FIXP) (* \; "Total number of elements")
|
||||
))
|
||||
|
||||
(DATATYPE TWOD-ARRAY ((NIL BITS 4) (* \; "For alignmnet")
|
||||
(BASE POINTER) (* \; "Raw storage pointer")
|
||||
(READ-ONLY-P FLAG) (* \; "8 bits of flags")
|
||||
(NIL BITS 1) (* \; "Twod arrays cann't be indirect")
|
||||
(BIT-P FLAG)
|
||||
(NIL BITS 4) (* \;
|
||||
"Twod arrays cann't be strings, nor can they be adjustable, displaced, or have fill pointers")
|
||||
(EXTENDABLE-P FLAG)
|
||||
(TYPE-NUMBER BITS 8)
|
||||
(NIL WORD) (* \;
|
||||
"Dummy, so TOTAL-SIZE is in right place")
|
||||
(BOUND0 FIXP) (* \; "Zero dimension bound")
|
||||
(TOTAL-SIZE FIXP) (* \;
|
||||
"Here to match the location of TOTAL-SIZE in other arrays...")
|
||||
(BOUND1 FIXP) (* \; "One dimension bound")
|
||||
))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'GENERAL-ARRAY '((BITS 4)
|
||||
POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8)
|
||||
WORD FIXP FIXP POINTER)
|
||||
'((GENERAL-ARRAY 0 (BITS . 3))
|
||||
(GENERAL-ARRAY 0 POINTER)
|
||||
(GENERAL-ARRAY 2 (FLAGBITS . 0))
|
||||
(GENERAL-ARRAY 2 (FLAGBITS . 16))
|
||||
(GENERAL-ARRAY 2 (FLAGBITS . 32))
|
||||
(GENERAL-ARRAY 2 (FLAGBITS . 48))
|
||||
(GENERAL-ARRAY 2 (FLAGBITS . 64))
|
||||
(GENERAL-ARRAY 2 (FLAGBITS . 80))
|
||||
(GENERAL-ARRAY 2 (FLAGBITS . 96))
|
||||
(GENERAL-ARRAY 2 (FLAGBITS . 112))
|
||||
(GENERAL-ARRAY 2 (BITS . 135))
|
||||
(GENERAL-ARRAY 3 (BITS . 15))
|
||||
(GENERAL-ARRAY 4 FIXP)
|
||||
(GENERAL-ARRAY 6 FIXP)
|
||||
(GENERAL-ARRAY 8 POINTER))
|
||||
'10)
|
||||
|
||||
(/DECLAREDATATYPE 'ONED-ARRAY '((BITS 4)
|
||||
POINTER FLAG (BITS 1)
|
||||
FLAG FLAG (BITS 1)
|
||||
FLAG FLAG FLAG (BITS 8)
|
||||
WORD FIXP FIXP)
|
||||
'((ONED-ARRAY 0 (BITS . 3))
|
||||
(ONED-ARRAY 0 POINTER)
|
||||
(ONED-ARRAY 2 (FLAGBITS . 0))
|
||||
(ONED-ARRAY 2 (BITS . 16))
|
||||
(ONED-ARRAY 2 (FLAGBITS . 32))
|
||||
(ONED-ARRAY 2 (FLAGBITS . 48))
|
||||
(ONED-ARRAY 2 (BITS . 64))
|
||||
(ONED-ARRAY 2 (FLAGBITS . 80))
|
||||
(ONED-ARRAY 2 (FLAGBITS . 96))
|
||||
(ONED-ARRAY 2 (FLAGBITS . 112))
|
||||
(ONED-ARRAY 2 (BITS . 135))
|
||||
(ONED-ARRAY 3 (BITS . 15))
|
||||
(ONED-ARRAY 4 FIXP)
|
||||
(ONED-ARRAY 6 FIXP))
|
||||
'8)
|
||||
|
||||
(/DECLAREDATATYPE 'TWOD-ARRAY '((BITS 4)
|
||||
POINTER FLAG (BITS 1)
|
||||
FLAG
|
||||
(BITS 4)
|
||||
FLAG
|
||||
(BITS 8)
|
||||
WORD FIXP FIXP FIXP)
|
||||
'((TWOD-ARRAY 0 (BITS . 3))
|
||||
(TWOD-ARRAY 0 POINTER)
|
||||
(TWOD-ARRAY 2 (FLAGBITS . 0))
|
||||
(TWOD-ARRAY 2 (BITS . 16))
|
||||
(TWOD-ARRAY 2 (FLAGBITS . 32))
|
||||
(TWOD-ARRAY 2 (BITS . 51))
|
||||
(TWOD-ARRAY 2 (FLAGBITS . 112))
|
||||
(TWOD-ARRAY 2 (BITS . 135))
|
||||
(TWOD-ARRAY 3 (BITS . 15))
|
||||
(TWOD-ARRAY 4 FIXP)
|
||||
(TWOD-ARRAY 6 FIXP)
|
||||
(TWOD-ARRAY 8 FIXP))
|
||||
'10)
|
||||
|
||||
|
||||
|
||||
(* |;;| "Cmlarray support macros and functions")
|
||||
|
||||
|
||||
|
||||
|
||||
(* \; "Fast predicates")
|
||||
|
||||
|
||||
(DEFMACRO %ARRAYP (ARRAY)
|
||||
(CL:IF (CL:SYMBOLP ARRAY)
|
||||
`(OR (%ONED-ARRAY-P ,ARRAY)
|
||||
(%TWOD-ARRAY-P ,ARRAY)
|
||||
(%GENERAL-ARRAY-P ,ARRAY))
|
||||
(LET ((SYM (GENSYM)))
|
||||
`(LET ((,SYM ,ARRAY))
|
||||
(OR (%ONED-ARRAY-P ,SYM)
|
||||
(%TWOD-ARRAY-P ,SYM)
|
||||
(%GENERAL-ARRAY-P ,SYM))))))
|
||||
|
||||
(DEFMACRO %SIMPLE-ARRAY-P (ARRAY)
|
||||
(CL:IF (CL:SYMBOLP ARRAY)
|
||||
`(AND (%ARRAYP ,ARRAY)
|
||||
(|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,ARRAY))
|
||||
(LET ((SYM (GENSYM)))
|
||||
`(LET ((,SYM ,ARRAY))
|
||||
(AND (%ARRAYP ,SYM)
|
||||
(|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,SYM))))))
|
||||
|
||||
(DEFMACRO %SIMPLE-STRING-P (STRING)
|
||||
(CL:IF (CL:SYMBOLP STRING)
|
||||
`(AND (%ONED-ARRAY-P ,STRING)
|
||||
(|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,STRING)
|
||||
(|fetch| (ARRAY-HEADER STRING-P) |of| ,STRING))
|
||||
(LET ((SYM (GENSYM)))
|
||||
`(LET ((,SYM ,STRING))
|
||||
(AND (%ONED-ARRAY-P ,SYM)
|
||||
(|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,SYM)
|
||||
(|fetch| (ARRAY-HEADER STRING-P) |of| ,SYM))))))
|
||||
|
||||
(DEFMACRO %STRINGP (STRING)
|
||||
(CL:IF (CL:SYMBOLP STRING)
|
||||
`(AND (OR (%ONED-ARRAY-P ,STRING)
|
||||
(%GENERAL-ARRAY-P ,STRING))
|
||||
(|fetch| (ARRAY-HEADER STRING-P) |of| ,STRING))
|
||||
(LET ((SYM (GENSYM)))
|
||||
`(LET ((,SYM ,STRING))
|
||||
(AND (OR (%ONED-ARRAY-P ,SYM)
|
||||
(%GENERAL-ARRAY-P ,SYM))
|
||||
(|fetch| (ARRAY-HEADER STRING-P) |of| ,SYM))))))
|
||||
|
||||
(DEFMACRO %VECTORP (VECTOR)
|
||||
(CL:IF (CL:SYMBOLP VECTOR)
|
||||
`(OR (%ONED-ARRAY-P ,VECTOR)
|
||||
(AND (%GENERAL-ARRAY-P ,VECTOR)
|
||||
(EQL 1 (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ,VECTOR)))))
|
||||
(LET ((SYM (GENSYM)))
|
||||
`(LET ((,SYM ,VECTOR))
|
||||
(OR (%ONED-ARRAY-P ,SYM)
|
||||
(AND (%GENERAL-ARRAY-P ,SYM)
|
||||
(EQL 1 (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ,SYM)))))))))
|
||||
|
||||
(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")
|
||||
|
||||
`(LET (CIRCLELABEL FIRSTTIME)
|
||||
(AND *PRINT-CIRCLE-HASHTABLE* (CL:MULTIPLE-VALUE-SETQ (CIRCLELABEL FIRSTTIME)
|
||||
(PRINT-CIRCLE-LOOKUP ,OBJECT)))
|
||||
(CL:WHEN CIRCLELABEL
|
||||
(.SPACECHECK. ,STREAM (VECTOR-LENGTH CIRCLELABEL))
|
||||
(LET (*PRINT-CIRCLE-HASHTABLE*)
|
||||
(DECLARE (CL:SPECIAL *PRINT-CIRCLE-HASHTABLE*))
|
||||
(* \;
|
||||
"No need to print-circle this string (dangerous if we do, in fact)")
|
||||
(CL:WRITE-STRING CIRCLELABEL ,STREAM))
|
||||
(CL:WHEN FIRSTTIME
|
||||
(.SPACECHECK. ,STREAM 1)
|
||||
(CL:WRITE-CHAR #\Space ,STREAM)))
|
||||
(CL:WHEN (OR (NOT CIRCLELABEL)
|
||||
FIRSTTIME)
|
||||
,@PRINT-FORMS)))
|
||||
|
||||
(DEFMACRO %CHECK-INDICES (ARRAY START-ARG ARGS)
|
||||
`(CL:DO ((I ,START-ARG (CL:1+ I))
|
||||
(DIM 0 (CL:1+ DIM))
|
||||
INDEX)
|
||||
((> I ,ARGS)
|
||||
T)
|
||||
(SETQ INDEX (ARG ,ARGS I))
|
||||
(CL:IF (OR (< INDEX 0)
|
||||
(>= INDEX (CL:ARRAY-DIMENSION ,ARRAY DIM)))
|
||||
(RETURN NIL))))
|
||||
|
||||
(DEFMACRO %CHECK-NOT-WRITEABLE (ARRAY TYPE-NUMBER NEWVALUE)
|
||||
`(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)
|
||||
`(PROGN (CL:IF (NOT (BIT-ARRAY-P ,BIT-ARRAY1))
|
||||
(CL:ERROR "BIT-ARRAY1 not a bit array: ~S" ,BIT-ARRAY1))
|
||||
(CL:IF (NOT (BIT-ARRAY-P ,BIT-ARRAY2))
|
||||
(CL:ERROR "BIT-ARRAY2 not a bit array: ~S" ,BIT-ARRAY2))
|
||||
(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 (CL:MAKE-ARRAY (CL:ARRAY-DIMENSIONS ,BIT-ARRAY1)
|
||||
:ELEMENT-TYPE
|
||||
'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")))
|
||||
,(CL:ECASE OP
|
||||
((AND IOR XOR ANDC2 ORC2) `(OR (EQ ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)
|
||||
(%DO-LOGICAL-OP 'COPY ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)))
|
||||
((EQV NAND NOR ANDC1 ORC1) `(%DO-LOGICAL-OP 'NOT ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)))
|
||||
,(CL:ECASE OP
|
||||
(AND `(%DO-LOGICAL-OP 'AND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(IOR `(%DO-LOGICAL-OP 'OR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(XOR `(%DO-LOGICAL-OP 'XOR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(EQV `(%DO-LOGICAL-OP 'XOR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(NAND `(%DO-LOGICAL-OP 'COR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(NOR `(%DO-LOGICAL-OP 'CAND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(ANDC1 `(%DO-LOGICAL-OP 'AND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(ANDC2 `(%DO-LOGICAL-OP 'CAND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(ORC1 `(%DO-LOGICAL-OP 'OR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
|
||||
(ORC2 `(%DO-LOGICAL-OP 'COR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)))
|
||||
,RESULT-BIT-ARRAY))
|
||||
|
||||
(DEFMACRO %GENERAL-ARRAY-ADJUST-BASE (ARRAY ROW-MAJOR-INDEX)
|
||||
`(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)
|
||||
`(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)
|
||||
`(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)
|
||||
`(EQ ,TYPE-NUMBER %BIT-TYPE))
|
||||
|
||||
(DEFMACRO %CHAR-TYPE-P (TYPE-NUMBER)
|
||||
`(EQ (%TYPENUMBER-TO-TYPE ,TYPE-NUMBER)
|
||||
%CHAR-TYPE))
|
||||
|
||||
(DEFMACRO %CML-TYPE-TO-TYPENUMBER-EXPANDER (CML-TYPE)
|
||||
|
||||
(* *)
|
||||
|
||||
(LET
|
||||
((SIMPLE-TYPES (REMOVE T (CL:MAPCAN #'(CL:LAMBDA (ENTRY)
|
||||
(CL:IF (NOT (LISTP (CAR ENTRY)))
|
||||
(LIST (CAR ENTRY))))
|
||||
%CANONICAL-CML-TYPES)))
|
||||
(COMPOUND-TYPES (CL:REMOVE-DUPLICATES (CL:MAPCAN #'(CL:LAMBDA (ENTRY)
|
||||
(CL:IF (LISTP (CAR ENTRY))
|
||||
(LIST (CAAR ENTRY))))
|
||||
%CANONICAL-CML-TYPES))))
|
||||
`(CL:IF (EQ ,CML-TYPE T)
|
||||
,(CADR (CL:ASSOC T %CANONICAL-CML-TYPES))
|
||||
(CL:IF (LISTP ,CML-TYPE)
|
||||
(CL:ECASE (CAR ,CML-TYPE)
|
||||
(\\\,@
|
||||
(CL:MAPCAR
|
||||
#'(CL:LAMBDA
|
||||
(TYPE)
|
||||
`(,TYPE (CL:ECASE (CADR ,CML-TYPE)
|
||||
(\\\,@ (CL:MAPCAN #'(CL:LAMBDA (ENTRY)
|
||||
(CL:IF (AND (LISTP (CAR ENTRY))
|
||||
(EQ (CAAR ENTRY)
|
||||
TYPE))
|
||||
(LIST (LIST (CADAR ENTRY)
|
||||
(CADR ENTRY)))))
|
||||
%CANONICAL-CML-TYPES)))))
|
||||
COMPOUND-TYPES)))
|
||||
(CL:ECASE ,CML-TYPE
|
||||
(\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPE)
|
||||
(CL:ASSOC TYPE %CANONICAL-CML-TYPES))
|
||||
SIMPLE-TYPES)))))))
|
||||
|
||||
(DEFMACRO %FAT-CHAR-TYPE-P (TYPE-NUMBER)
|
||||
`(EQ ,TYPE-NUMBER %FAT-CHAR-TYPENUMBER))
|
||||
|
||||
(DEFMACRO %FAT-STRING-CHAR-P (OBJECT)
|
||||
`(> (CL:CHAR-CODE ,OBJECT)
|
||||
%MAXTHINCHAR))
|
||||
|
||||
(CL:DEFUN %GET-TYPE-TABLE-ENTRY (TYPENUMBER)
|
||||
(CADR (CL:ASSOC TYPENUMBER %ARRAY-TYPE-TABLE)))
|
||||
|
||||
(CL:DEFUN %LIT-SIZE-TO-SIZE (LIT-SIZE)
|
||||
(CADR (CL:ASSOC LIT-SIZE %LIT-ARRAY-SIZES)))
|
||||
|
||||
(CL:DEFUN %LIT-TYPE-TO-TYPE (LIT-TYPE)
|
||||
(CADR (CL:ASSOC LIT-TYPE %LIT-ARRAY-TYPES)))
|
||||
|
||||
(CL: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)))
|
||||
`(,ACCESSOR ,BASE ,(CL:IF NEEDS-SHIFT-P
|
||||
`(LLSH ,OFFSET ,NEEDS-SHIFT-P)
|
||||
OFFSET))))
|
||||
|
||||
(CL: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)))
|
||||
`(,SETTOR ,BASE ,(CL:IF NEEDS-SHIFT-P
|
||||
`(LLSH ,OFFSET ,NEEDS-SHIFT-P)
|
||||
OFFSET)
|
||||
,NEWVALUE)))
|
||||
|
||||
(DEFMACRO %LLARRAY-TYPED-GET (BASE TYPENUMBER OFFSET)
|
||||
`(CL:ECASE ,TYPENUMBER
|
||||
(\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY)
|
||||
`(,(CAR TYPEENTRY)
|
||||
,(%LLARRAY-MAKE-ACCESSOR-EXPR (CAR TYPEENTRY)
|
||||
BASE OFFSET)))
|
||||
%ARRAY-TYPE-TABLE))))
|
||||
|
||||
(DEFMACRO %LLARRAY-TYPED-PUT (BASE TYPENUMBER OFFSET NEWVALUE)
|
||||
`(CL:ECASE ,TYPENUMBER
|
||||
(\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY)
|
||||
`(,(CAR TYPEENTRY)
|
||||
,(%LLARRAY-MAKE-SETTOR-EXPR (CAR TYPEENTRY)
|
||||
BASE OFFSET NEWVALUE)))
|
||||
%ARRAY-TYPE-TABLE))))
|
||||
|
||||
(DEFMACRO %LLARRAY-TYPEP (TYPENUMBER VALUE)
|
||||
`(CL:ECASE ,TYPENUMBER
|
||||
(\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY)
|
||||
`(,(CAR TYPEENTRY)
|
||||
(,(ARRAY-TABLE-ENTRY-TYPE-TEST (CADR TYPEENTRY))
|
||||
,VALUE)))
|
||||
%ARRAY-TYPE-TABLE))))
|
||||
|
||||
(CL:DEFUN %MAKE-ARRAY-TYPE-TABLE (LIT-TABLE TYPES SIZES)
|
||||
(CL:MAPCAN #'(CL:LAMBDA (TYPE-ENTRY)
|
||||
(LET ((LIT-TYPE (CAR TYPE-ENTRY)))
|
||||
(CL:MAPCAR #'(CL:LAMBDA (SIZE-ENTRY)
|
||||
(LIST (%TYPE-SIZE-TO-TYPENUMBER LIT-TYPE
|
||||
(CAR SIZE-ENTRY))
|
||||
(CADR SIZE-ENTRY)))
|
||||
(CADR TYPE-ENTRY))))
|
||||
LIT-TABLE))
|
||||
|
||||
(CL:DEFUN %MAKE-CML-TYPE-TABLE (ARRAY-TABLE)
|
||||
(CL:MAPCAR #'(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)
|
||||
`(\\ADDBASE (LLSH ,ELTTYPE 4)
|
||||
,ELTSIZE))
|
||||
|
||||
(DEFMACRO %SMALLFIXP-SMALLPOSP (NUM)
|
||||
`(\\LOLOC ,NUM))
|
||||
|
||||
(DEFMACRO %SMALLPOSP-SMALLFIXP (NUM)
|
||||
(LET ((SYM (GENSYM)))
|
||||
`(LET ((,SYM ,NUM))
|
||||
(CL:IF (> ,SYM MAX.SMALLFIXP)
|
||||
(\\VAG2 |\\SmallNegHi| ,SYM)
|
||||
,SYM))))
|
||||
|
||||
(DEFMACRO %THIN-CHAR-TYPE-P (TYPE-NUMBER)
|
||||
`(EQ ,TYPE-NUMBER %THIN-CHAR-TYPENUMBER))
|
||||
|
||||
(DEFMACRO %THIN-STRING-CHAR-P (OBJECT)
|
||||
`(<= (CL:CHAR-CODE ,OBJECT)
|
||||
%MAXTHINCHAR))
|
||||
|
||||
(CL: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)
|
||||
`(CL:ECASE ,TYPE-NUMBER
|
||||
(\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY)
|
||||
`(,(CAR TYPEENTRY)
|
||||
,(ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT (CADR TYPEENTRY))))
|
||||
%ARRAY-TYPE-TABLE))))
|
||||
|
||||
(DEFMACRO %TYPENUMBER-TO-CML-TYPE (TYPE-NUMBER)
|
||||
`(CL:ECASE ,TYPE-NUMBER
|
||||
(\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY)
|
||||
`(,(CAR TYPEENTRY)
|
||||
',(ARRAY-TABLE-ENTRY-CML-TYPE (CADR TYPEENTRY))))
|
||||
%ARRAY-TYPE-TABLE))))
|
||||
|
||||
(DEFMACRO %TYPENUMBER-TO-DEFAULT-VALUE (TYPE-NUMBER)
|
||||
`(CL:ECASE ,TYPE-NUMBER
|
||||
(\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY)
|
||||
`(,(CAR TYPEENTRY)
|
||||
,(ARRAY-TABLE-ENTRY-DEFAULT-VALUE (CADR TYPEENTRY))))
|
||||
%ARRAY-TYPE-TABLE))))
|
||||
|
||||
(DEFMACRO %TYPENUMBER-TO-GC-TYPE (TYPE-NUMBER)
|
||||
`(CL:ECASE ,TYPE-NUMBER
|
||||
(\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY)
|
||||
`(,(CAR TYPEENTRY)
|
||||
,(ARRAY-TABLE-ENTRY-GC-TYPE (CADR TYPEENTRY))))
|
||||
%ARRAY-TYPE-TABLE))))
|
||||
|
||||
(DEFMACRO %TYPENUMBER-TO-SIZE (TYPE-NUMBER)
|
||||
`(LOGAND ,TYPE-NUMBER 15))
|
||||
|
||||
(DEFMACRO %TYPENUMBER-TO-TYPE (TYPE-NUMBER)
|
||||
`(LRSH ,TYPE-NUMBER 4))
|
||||
|
||||
(DEFMACRO \\GETBASESMALL-FIXP (BASE OFFSET)
|
||||
`(%SMALLPOSP-SMALLFIXP (\\GETBASE ,BASE ,OFFSET)))
|
||||
|
||||
(DEFMACRO \\GETBASESTRING-CHAR (PTR DISP)
|
||||
`(CL:CODE-CHAR (\\GETBASE ,PTR ,DISP)))
|
||||
|
||||
(DEFMACRO \\GETBASETHINSTRING-CHAR (PTR DISP)
|
||||
`(CL:CODE-CHAR (\\GETBASEBYTE ,PTR ,DISP)))
|
||||
|
||||
(DEFMACRO \\PUTBASESMALL-FIXP (BASE OFFSET VALUE)
|
||||
`(\\PUTBASE ,BASE ,OFFSET (%SMALLFIXP-SMALLPOSP ,VALUE)))
|
||||
|
||||
(DEFMACRO \\PUTBASESTRING-CHAR (PTR DISP CHAR)
|
||||
`(\\PUTBASE ,PTR ,DISP (CL:CHAR-CODE ,CHAR)))
|
||||
|
||||
(DEFMACRO \\PUTBASETHINSTRING-CHAR (PTR DISP CHAR)
|
||||
`(\\PUTBASEBYTE ,PTR ,DISP (CL:CHAR-CODE ,CHAR)))
|
||||
|
||||
|
||||
|
||||
(* |;;;| "Describes each entry of \\ARRAY-TYPE-TABLE")
|
||||
|
||||
|
||||
(CL:DEFSTRUCT (ARRAY-TABLE-ENTRY (:TYPE LIST)
|
||||
(:CONSTRUCTOR NIL)
|
||||
(:COPIER NIL)
|
||||
(:PREDICATE NIL))
|
||||
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")
|
||||
|
||||
|
||||
(CL:DEFPARAMETER %LIT-ARRAY-SIZES '((1BIT 0)
|
||||
(8BIT 3)
|
||||
(16BIT 4)
|
||||
(32BIT 6))
|
||||
"Size codes")
|
||||
|
||||
(CL:DEFPARAMETER %LIT-ARRAY-TABLE
|
||||
'((CL:STRING-CHAR ((8BIT (CL:STRING-CHAR \\GETBASETHINSTRING-CHAR \\PUTBASETHINSTRING-CHAR 8
|
||||
UNBOXEDBLOCK.GCT #\Null NIL (CL:LAMBDA (OBJECT)
|
||||
(%THIN-STRING-CHAR-P OBJECT
|
||||
))))
|
||||
(16BIT (CL:STRING-CHAR \\GETBASESTRING-CHAR \\PUTBASESTRING-CHAR 16
|
||||
UNBOXEDBLOCK.GCT #\Null NIL (CL:LAMBDA (OBJECT)
|
||||
(CL: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)))))
|
||||
(CL:SINGLE-FLOAT ((32BIT (CL:SINGLE-FLOAT \\GETBASEFLOATP \\PUTBASEFLOATP 32 UNBOXEDBLOCK.GCT
|
||||
0.0 1 (CL:LAMBDA (OBJECT)
|
||||
(FLOATP OBJECT))))))
|
||||
(CL:UNSIGNED-BYTE ((1BIT ((CL:UNSIGNED-BYTE 1)
|
||||
\\GETBASEBIT \\PUTBASEBIT 1 UNBOXEDBLOCK.GCT 0 NIL
|
||||
(CL:LAMBDA (OBJECT)
|
||||
(AND (>= OBJECT 0)
|
||||
(<= OBJECT 1)))))
|
||||
(8BIT ((CL:UNSIGNED-BYTE 8)
|
||||
\\GETBASEBYTE \\PUTBASEBYTE 8 UNBOXEDBLOCK.GCT 0 NIL
|
||||
(CL:LAMBDA (OBJECT)
|
||||
(AND (>= OBJECT 0)
|
||||
(< OBJECT 256)))))
|
||||
(16BIT ((CL:UNSIGNED-BYTE 16)
|
||||
\\GETBASE \\PUTBASE 16 UNBOXEDBLOCK.GCT 0 NIL (CL:LAMBDA (OBJECT)
|
||||
(SMALLPOSP
|
||||
OBJECT))))))
|
||||
(CL:SIGNED-BYTE ((16BIT ((CL:SIGNED-BYTE 16)
|
||||
\\GETBASESMALL-FIXP \\PUTBASESMALL-FIXP 16 UNBOXEDBLOCK.GCT 0 NIL
|
||||
(CL:LAMBDA (OBJECT)
|
||||
(AND (>= OBJECT MIN.SMALLFIXP)
|
||||
(<= OBJECT MAX.SMALLFIXP)))))
|
||||
(32BIT ((CL: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")
|
||||
|
||||
(CL:DEFPARAMETER %LIT-ARRAY-TYPES
|
||||
'((CL:UNSIGNED-BYTE 0)
|
||||
(CL:SIGNED-BYTE 1)
|
||||
(T 2)
|
||||
(CL:SINGLE-FLOAT 3)
|
||||
(CL:STRING-CHAR 4)
|
||||
(XPOINTER 5))
|
||||
"Type codes")
|
||||
|
||||
|
||||
|
||||
(* |;;;| "Tables that drives various macros")
|
||||
|
||||
|
||||
(CL:DEFPARAMETER %ARRAY-TYPE-TABLE (%MAKE-ARRAY-TYPE-TABLE %LIT-ARRAY-TABLE %LIT-ARRAY-TYPES
|
||||
%LIT-ARRAY-SIZES)
|
||||
"Drives various macros")
|
||||
|
||||
(CL:DEFPARAMETER %CANONICAL-CML-TYPES (%MAKE-CML-TYPE-TABLE %ARRAY-TYPE-TABLE))
|
||||
|
||||
|
||||
|
||||
(* |;;;| "Constants for (SIGNED-BYTE 16)")
|
||||
|
||||
|
||||
(CL:DEFCONSTANT MAX.SMALLFIXP (CL:1- (EXPT 2 15)))
|
||||
|
||||
(CL:DEFCONSTANT MIN.SMALLFIXP (- (EXPT 2 15)))
|
||||
|
||||
|
||||
|
||||
(* |;;;| "Constants for STRING-CHARS")
|
||||
|
||||
|
||||
(CL:DEFCONSTANT %CHAR-TYPE (%LIT-TYPE-TO-TYPE 'CL:STRING-CHAR))
|
||||
|
||||
(CL:DEFCONSTANT %BIT-TYPE (%TYPE-SIZE-TO-TYPENUMBER 'CL:UNSIGNED-BYTE '1BIT))
|
||||
|
||||
(CL:DEFCONSTANT %THIN-CHAR-TYPENUMBER (%TYPE-SIZE-TO-TYPENUMBER 'CL:STRING-CHAR '8BIT))
|
||||
|
||||
(CL:DEFCONSTANT %FAT-CHAR-TYPENUMBER (%TYPE-SIZE-TO-TYPENUMBER 'CL:STRING-CHAR '16BIT))
|
||||
|
||||
(CL:DEFCONSTANT %MAXTHINCHAR (CL:1- (EXPT 2 8)))
|
||||
|
||||
|
||||
|
||||
(* |;;;| "Array data-type numbers")
|
||||
|
||||
|
||||
(CL:DEFCONSTANT %GENERAL-ARRAY 16
|
||||
"General-array-type-number")
|
||||
|
||||
(CL:DEFCONSTANT %ONED-ARRAY 14
|
||||
"ONED-ARRAY type number")
|
||||
|
||||
(CL: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 CL:COMPILE-FILE)
|
||||
(PUTPROPS CMLARRAY-SUPPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1992 1994 1999))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
Reference in New Issue
Block a user