(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "18-Feb-88 11:36:24" {ERINYES}<LISPUSERS>LYRIC>DATATYPESPLUS.\;1 32709
|previous| |date:| "29-Jan-88 18:11:10" {QV}<BRIGGS>LISP>MAPLE>DATATYPESPLUS.\;4)
; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT DATATYPESPLUSCOMS)
(RPAQQ DATATYPESPLUSCOMS (
(* |;;| "System functions that (unfortunately) had to be redefined to add the record field types REVERSEDWORD and REVERSEDFIXP. These are a 16 bit (unsigned) word with LSB, MSB and a 32 bit integer with LSW, MSW in the same reversed word format.")
(* |;;| "")
(DECLARE\: DONTCOPY (FILES (LOADCOMP)
LLDATATYPE))
(FNS FETCHFIELD REPLACEFIELD COMPILEDFETCHFIELD COMPILEDREPLACEFIELD
TRANSLATE.DATATYPE \\PUTREVERSEDFIXP)
(* |;;| "")
(VARS DATATYPEFIELDTYPES)))
(* |;;|
"System functions that (unfortunately) had to be redefined to add the record field types REVERSEDWORD and REVERSEDFIXP. These are a 16 bit (unsigned) word with LSB, MSB and a 32 bit integer with LSW, MSW in the same reversed word format."
)
(* |;;| "")
(DECLARE\: DONTCOPY
(FILESLOAD (LOADCOMP)
LLDATATYPE)
)
(DEFINEQ
(FETCHFIELD
(LAMBDA (DESCRIPTOR DATUM) (* \; "Edited 17-Dec-87 18:45 by Briggs")
(* |;;| "retrieves a data field from a user data structure.")
(PROG ((TN (|fetch| |fdTypeName| |of| DESCRIPTOR))
(OFFSET (|fetch| |fdOffset| |of| DESCRIPTOR)))
(AND TN (SETQ DATUM (\\DTEST DATUM TN)))
(RETURN (SELECTQ (|fetch| |fdType| |of| DESCRIPTOR)
((POINTER XPOINTER FULLPOINTER FULLXPOINTER)
(\\GETBASEPTR DATUM OFFSET))
(FLOATP (MAKEFLOATNUMBER (\\GETBASE DATUM OFFSET)
(\\GETBASE (\\ADDBASE DATUM 1)
OFFSET)))
(FIXP (\\MAKENUMBER (\\GETBASE DATUM OFFSET)
(\\GETBASE (\\ADDBASE DATUM 1)
OFFSET)))
(SWAPPEDFIXP (\\MAKENUMBER (\\GETBASE (\\ADDBASE DATUM 1)
OFFSET)
(\\GETBASE DATUM OFFSET)))
(REVERSEDFIXP (PROG ((HI (\\GETBASE (\\ADDBASE DATUM 1)
OFFSET))
(LO (\\GETBASE DATUM OFFSET)))
(RETURN (\\MAKENUMBER (LOGOR (LRSH HI 8)
(LLSH (LOGAND HI 255)
8))
(LOGOR (LRSH LO 8)
(LLSH (LOGAND LO 255)
8))))))
(PROG ((FT (|fetch| |fdType| |of| DESCRIPTOR))
(OFF OFFSET))
(RETURN (SELECTQ (CAR FT)
(BITS (LOGAND (LRSH (\\GETBASE DATUM OFF)
(|BitFieldShift| (CDR FT)))
(|BitFieldMask| (CDR FT))))
(SIGNEDBITS ((LAMBDA (N WIDTH)
(COND
((IGREATERP N (SUB1 (LLSH 1 (SUB1 WIDTH))))
(SUB1 (IDIFFERENCE N
(SUB1 (LLSH 1 WIDTH)))))
(T N)))
(LOGAND (LRSH (\\GETBASE DATUM OFF)
(|BitFieldShift| (CDR FT)))
(|BitFieldMask| (CDR FT)))
(|BitFieldWidth| (CDR FT))))
(LONGBITS (\\MAKENUMBER (LOGAND (LRSH (\\GETBASE DATUM OFF)
(|BitFieldShift|
(CDR FT)))
(|BitFieldMask| (CDR FT)))
(\\GETBASE (\\ADDBASE DATUM 1)
OFF)))
(FLAGBITS (NEQ (LOGAND (\\GETBASE DATUM OFF)
(|BitFieldShiftedMask| (CDR FT)))
0))
(REVERSEDWORD (LOGOR (LRSH (\\GETBASE DATUM OFF)
8)
(LLSH (LOGAND (\\GETBASE DATUM OFF)
255)
8)))
(LISPERROR "ILLEGAL ARG" DESCRIPTOR)))))))))
(REPLACEFIELD
(LAMBDA (DESCRIPTOR DATUM NEWVALUE) (* \; "Edited 11-Dec-87 12:28 by N.H.Briggs")
(* \;
"replace a field in a user data structure. return coerced value.")
(PROG ((OFFSET (|fetch| |fdOffset| |of| DESCRIPTOR))
(FT (|fetch| |fdType| |of| DESCRIPTOR))
(TN (|fetch| |fdTypeName| |of| DESCRIPTOR))
SHIFT MASK)
(AND TN (SETQ DATUM (\\DTEST DATUM TN)))
(RETURN
(SELECTQ FT
((POINTER FULLPOINTER)
(\\RPLPTR DATUM OFFSET NEWVALUE))
(XPOINTER (* \; "no ref count, hi bits used")
(PUTBASEPTRX DATUM OFFSET NEWVALUE))
(FULLXPOINTER (\\PUTBASEPTR DATUM OFFSET NEWVALUE))
(FLOATP (\\PUTBASEFLOATP DATUM OFFSET NEWVALUE))
(FIXP (\\PUTFIXP (\\ADDBASE DATUM OFFSET)
NEWVALUE)
NEWVALUE)
(SWAPPEDFIXP (\\PUTSWAPPEDFIXP (\\ADDBASE DATUM OFFSET)
NEWVALUE)
NEWVALUE)
(REVERSEDFIXP (\\PUTREVERSEDFIXP (\\ADDBASE DATUM OFFSET)
NEWVALUE)
NEWVALUE)
(SELECTQ (CAR FT)
(BITS (LOGAND (LRSH (\\PUTBASE DATUM OFFSET
(LOGOR (LOGAND (\\GETBASE DATUM OFFSET)
(LOGXOR 65535
(LLSH (SETQ MASK
(|BitFieldMask|
(CDR FT)))
(SETQ SHIFT
(|BitFieldShift|
(CDR FT))))))
(LLSH (LOGAND NEWVALUE MASK)
SHIFT)))
SHIFT)
MASK))
(SIGNEDBITS ((LAMBDA (X)
(COND
((IGREATERP X (SUB1 (LLSH 1 (SUB1 (|BitFieldWidth| (CDR FT))))))
(SUB1 (IDIFFERENCE X (SUB1 (LLSH 1 (|BitFieldWidth|
(CDR FT)))))))
(T X)))
(LOGAND
(LRSH
(\\PUTBASE
DATUM OFFSET
(LOGOR (LOGAND (\\GETBASE DATUM OFFSET)
(LOGXOR 65535 (LLSH (SETQ MASK (|BitFieldMask|
(CDR FT)))
(SETQ SHIFT (|BitFieldShift|
(CDR FT))))))
(LLSH (LOGAND (LOGAND NEWVALUE
(SUB1 (LLSH 1 (|BitFieldWidth|
(CDR FT)))))
MASK)
SHIFT)))
SHIFT)
MASK)))
(FLAGBITS (\\PUTBASE DATUM OFFSET
(LOGOR (LOGAND (\\GETBASE DATUM OFFSET)
(LOGXOR 65535 (LLSH (SETQ MASK (|BitFieldMask|
(CDR FT)))
(SETQ SHIFT (|BitFieldShift|
(CDR FT))))))
(LLSH (LOGAND (COND
(NEWVALUE 65535)
(T 0))
MASK)
SHIFT)))
(AND NEWVALUE T))
(LONGBITS (PROG (LO HI)
(.UNBOX. NEWVALUE HI LO)
(UNINTERRUPTABLY
(\\PUTBASE DATUM OFFSET
(LOGOR (LOGAND (\\GETBASE DATUM OFFSET)
(LOGXOR 65535
(LLSH (SETQ MASK
(|BitFieldMask|
(CDR FT)))
(SETQ SHIFT
(|BitFieldShift|
(CDR FT))))))
(LLSH (LOGAND HI MASK)
SHIFT)))
(\\PUTBASE DATUM (ADD1 OFFSET)
LO)))
NEWVALUE)
(REVERSEDWORD (\\PUTBASE DATUM OFFSET (LOGOR (LRSH NEWVALUE 8)
(LLSH (LOGAND NEWVALUE 255)
8)))
NEWVALUE)
(LISPERROR "ILLEGAL ARG" DESCRIPTOR)))))))
(COMPILEDFETCHFIELD
(LAMBDA (X FASTFLG) (* \; "Edited 15-Dec-87 12:33 by N.H.Briggs")
(COND
((EQ (CAR (LISTP (CAR X)))
'QUOTE)
((LAMBDA (DESCRIPTOR DATUM)
(PROG (TYPENAME)
(COND
((AND (NOT FASTFLG)
(SETQ TYPENAME (|fetch| |fdTypeName| |of| DESCRIPTOR)))
(SETQ DATUM (LIST (FUNCTION \\DTEST)
DATUM
(KWOTE TYPENAME)))))
(RETURN
(SELECTQ (|fetch| |fdType| |of| DESCRIPTOR)
((POINTER XPOINTER FULLPOINTER FULLXPOINTER)
(LIST '\\GETBASEPTR DATUM (|fetch| |fdOffset| |of| DESCRIPTOR)))
(SWAPPEDXPOINTER
`((OPENLAMBDA (D)
(\\VAG2 (\\GETBASE D ,(ADD1 (|fetch| |fdOffset| |of| DESCRIPTOR))
)
(\\GETBASE D ,(|fetch| |fdOffset| |of| DESCRIPTOR))))
,DATUM))
(FLOATP `(\\GETBASEFLOATP ,DATUM ,(|fetch| |fdOffset| |of| DESCRIPTOR)))
(FIXP `(\\GETBASEFIXP ,DATUM ,(|fetch| |fdOffset| |of| DESCRIPTOR)))
(SWAPPEDFIXP `((OPENLAMBDA (D)
(\\MAKENUMBER (\\GETBASE D
,(ADD1 (|fetch| |fdOffset|
|of| DESCRIPTOR)))
(\\GETBASE D ,(|fetch| |fdOffset| |of| DESCRIPTOR)
)))
,DATUM))
(REVERSEDFIXP `((OPENLAMBDA
(D)
(\\MAKENUMBER
(LOGOR (LRSH (\\GETBASE D ,(ADD1 (|fetch| |fdOffset|
|of| DESCRIPTOR)))
8)
(LLSH (LOGAND (\\GETBASE D
,(ADD1 (|fetch| |fdOffset|
|of| DESCRIPTOR)))
255)
8))
(LOGOR (LRSH (\\GETBASE D ,(|fetch| |fdOffset| |of|
DESCRIPTOR
))
8)
(LLSH (LOGAND (\\GETBASE D
,(|fetch| |fdOffset| |of|
DESCRIPTOR
))
255)
8))))
,DATUM))
(PROG ((FT (|fetch| |fdType| |of| DESCRIPTOR))
(OFF (|fetch| |fdOffset| |of| DESCRIPTOR)))
(RETURN (SELECTQ (CAR FT)
(BITS (LIST '\\GETBITS DATUM OFF (CDR FT)))
(SIGNEDBITS `(SIGNED (\\GETBITS ,DATUM ,OFF
,(CDR FT))
,(|BitFieldWidth| (CDR FT))))
(FLAGBITS (LIST '\\TESTBITS DATUM OFF (CDR FT)))
(REVERSEDWORD `((OPENLAMBDA (D)
(LOGOR (\\GETBITS D ,OFF 7)
(LLSH (\\GETBITS D ,OFF 135)
8)))
,DATUM))
(LONGBITS `((OPENLAMBDA (D)
(\\MAKENUMBER (\\GETBITS
D
,OFF
,(CDR FT))
(\\GETBASE D ,(ADD1 OFF))))
,DATUM))
(SHOULDNT))))))))
(CADAR X)
(CADR X)))
(T 'IGNOREMACRO))))
(COMPILEDREPLACEFIELD
(LAMBDA (X FASTFLG RPLVALFLG) (* \; "Edited 29-Jan-88 17:50 by Briggs")
(* |compile| |code| |for| |replacing| |field| |values.|
|Goes| |to| |great| |length| |to| |ensure| |that| |the| |coerced| |value| |is|
|returned|)
(COND
((EQ (CAR (LISTP (CAR X)))
'QUOTE)
((LAMBDA (DESCRIPTOR DATUM NEWVALUE)
(PROG ((TYPENAME (|fetch| |fdTypeName| |of| DESCRIPTOR))
(FT (|fetch| |fdType| |of| DESCRIPTOR))
(OFFSET (|fetch| |fdOffset| |of| DESCRIPTOR)))
(COND
((AND (NOT FASTFLG)
TYPENAME)
(SETQ DATUM (LIST (FUNCTION \\DTEST)
DATUM
(KWOTE TYPENAME)))))
(RETURN (SELECTQ FT
((POINTER FULLPOINTER)
(LIST (FUNCTION \\RPLPTR)
DATUM OFFSET NEWVALUE))
(XPOINTER (LIST (FUNCTION PUTBASEPTRX)
DATUM OFFSET NEWVALUE))
(FULLXPOINTER (LIST '\\PUTBASEPTR DATUM OFFSET NEWVALUE))
(SWAPPEDXPOINTER
`((OPENLAMBDA (D R)
(\\PUTBASE D ,OFFSET (\\LOLOC R))
(\\PUTBASE D ,(ADD1 OFFSET) (\\HILOC R))
R)
,DATUM
,NEWVALUE))
(FIXP `(\\PUTBASEFIXP ,DATUM ,OFFSET ,NEWVALUE))
(SWAPPEDFIXP `(\\PUTSWAPPEDFIXP (\\ADDBASE ,DATUM ,OFFSET)
,NEWVALUE))
(REVERSEDFIXP `(\\PUTREVERSEDFIXP (\\ADDBASE ,DATUM ,OFFSET)
,NEWVALUE))
(FLOATP `(\\PUTBASEFLOATP ,DATUM ,OFFSET ,NEWVALUE))
(SELECTQ (CAR FT)
(BITS (LIST '\\PUTBITS DATUM OFFSET (CDR FT)
NEWVALUE))
(REVERSEDWORD `((OPENLAMBDA (D V)
(\\PUTBITS D ,OFFSET 7 (LOGAND V 255))
(\\PUTBITS D ,OFFSET 135 (LRSH V 8))
V)
,DATUM
,NEWVALUE))
(LONGBITS (LIST (SUBPAIR '(OFFSET FT) (LIST OFFSET (CDR FT))
'(OPENLAMBDA (D V)
(\\PUTBITS D OFFSET FT (\\HINUM
V))
(\\PUTBASE D (ADD1 OFFSET)
(\\LONUM V))
V))
DATUM NEWVALUE))
(SIGNEDBITS `(SIGNED (\\PUTBITS ,DATUM ,OFFSET ,(CDR FT)
(UNSIGNED ,NEWVALUE
,(|BitFieldWidth| (CDR FT))))
,(|BitFieldWidth| (CDR FT))))
(FLAGBITS `(NEQ (\\PUTBITS ,DATUM ,OFFSET ,(CDR FT)
(COND
(,NEWVALUE ,(|BitFieldMask| (CDR FT)))
(T 0)))
0))
(RETURN 'IGNOREMACRO))))))
(CADAR X)
(CADR X)
(CADDR X)))
(T 'IGNOREMACRO))))
(TRANSLATE.DATATYPE
(LAMBDA (TYPENAME FIELDSPECS) (* DECLARATIONS\: (RECORD SPEC
(N LEN . FD)))
(DECLARE (SPECVARS TYPENAME UNUSED BIT OFFSET FD)) (* \;
"Edited 11-Dec-87 12:00 by N.H.Briggs")
(COND
((NULL TYPENAME))
((OR (NOT (LITATOM TYPENAME))
(EQ TYPENAME '**DEALLOC**))
(ERROR "Invalid type name" TYPENAME)))
(PROG ((N 0)
UNUSED
(OFFSET 0)
(BIT 0)
DLIST REUSE LEN FD)
(SETQ DLIST (|for| S |in| FIELDSPECS
|collect| (|create| SPEC
N ← (|add| N 1)
LEN ← (SELECTQ S
((POINTER XPOINTER)
24)
((FIXP FLOATP SWAPPEDFIXP REVERSEDFIXP
FULLPOINTER SWAPPEDXPOINTER FULLXPOINTER)
BITSPERCELL)
(FLAG (SETQQ S FLAGBITS)
1)
(BYTE (SETQQ S BITS)
BITSPERBYTE)
(WORD (SETQQ S BITS)
BITSPERWORD)
(REVERSEDWORD BITSPERWORD)
(SIGNEDWORD (SETQQ S SIGNEDBITS)
BITSPERWORD)
(SELECTQ (CAR (LISTP S))
((BITS FLAGBITS SIGNEDBITS)
(PROG1 (CADR S)
(SETQ S (CAR S))))
(ERROR "invalid field spec: " S)))
FD ←
(|create| |FldDsc|
|fdTypeName| ← TYPENAME
|fdType| ← S
|fdOffset| ← NIL))))
(|for| S |in| DLIST
|do|
(|replace| |fdOffset| |of| (SETQ FD (|fetch| FD |of| S))
|with|
(SELECTQ (|fetch| |fdType| |of| FD)
((POINTER XPOINTER)
(COND
((AND TYPENAME
(|find| X |in| UNUSED
|suchthat| (AND (EQ 0 (LOGAND (CAR X)
1))
(IGEQ (CADDR X)
8)
(EQ (IPLUS (CADR X)
(CADDR X))
BITSPERWORD)
(|find| Y |in| UNUSED
|suchthat| (AND (EQ (CAR Y)
(ADD1 (CAR X)))
(EQ (CADDR Y)
BITSPERWORD))))))
(* |unused| 24 |bit| |quantity|)
(* |this| |case| |not| |implemented|
|yet|)
))
(COND
((IGREATERP BIT 8) (* |Less| |than| 8 |bits| |left| |in|
|this| |word|)
(\\REUSETO BITSPERWORD)))
(COND
((ODDP OFFSET WORDSPERCELL) (* |not| |on| |double| |word|
|boundary|)
(\\REUSETO BITSPERWORD)))
(COND
((NEQ BIT 8)
(\\REUSETO 8 (EQ BIT 0))))
(SETQ BIT 0)
(PROG1 OFFSET (|add| OFFSET WORDSPERCELL)))
((FIXP SWAPPEDFIXP REVERSEDFIXP FLOATP SWAPPEDXPOINTER)
(* 32 |bit| |quantities|)
(COND
((NEQ BIT 0)
(\\REUSETO BITSPERWORD)))
(PROG1 OFFSET (|add| OFFSET WORDSPERCELL)))
((FULLPOINTER FULLXPOINTER) (* 32 |bit| |doubleword-aligned|
|quantities|)
(COND
((NEQ BIT 0)
(\\REUSETO BITSPERWORD)))
(COND
((ODDP OFFSET WORDSPERCELL)
(\\REUSETO BITSPERWORD)))
(PROG1 OFFSET (|add| OFFSET WORDSPERCELL)))
((BITS FLAGBITS SIGNEDBITS REVERSEDWORD)
(SETQ LEN (|fetch| LEN |of| S))
(COND
((AND TYPENAME (SETQ REUSE (|find| X |in| UNUSED
|suchthat| (ILEQ LEN (CADDR X)))))
(RPLACA (CDDR REUSE)
(IDIFFERENCE (CAR (CDDR REUSE))
LEN))
(|replace| |fdType| |of| FD |with| (CONS (|fetch| |fdType| |of| FD)
(|MakeBitField| (CADR REUSE)
LEN)))
(|add| (CADR REUSE)
LEN)
(CAR REUSE))
((IGREATERP LEN BITSPERWORD)
(* |more| |than| 1 |word| -
|Must| |right| |justify| |first| |word|)
(SETQ LEN (IDIFFERENCE LEN BITSPERWORD))
(COND
((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT))
(\\REUSETO BITSPERWORD)))
(COND
((NEQ (IDIFFERENCE BITSPERWORD BIT)
LEN)
(\\REUSETO (IDIFFERENCE BITSPERWORD LEN))))
(|replace| |fdType| |of| FD |with| (CONS 'LONGBITS (|MakeBitField|
BIT LEN)))
(SETQ BIT 0)
(PROG1 OFFSET (|add| OFFSET 2)))
(T (COND
((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT))
(\\REUSETO BITSPERWORD)))
(|replace| |fdType| |of| FD |with| (CONS (|fetch| |fdType|
|of| FD)
(|MakeBitField| BIT LEN)))
(|add| BIT LEN)
(PROG1 OFFSET (COND
((EQ BIT BITSPERWORD)
(SETQ BIT 0)
(|add| OFFSET 1)))))))
(SHOULDNT))))
(COND
(TYPENAME (COND
((NEQ BIT 0)
(\\REUSETO BITSPERWORD)))
(|while| (ODDP OFFSET WORDSPERCELL) |do| (|add| OFFSET 1))
(COND
((IGREATERP OFFSET |\\MDSIncrement|)
(ERROR TYPENAME "DATATYPE TOO BIG")))))
(RETURN (CONS OFFSET (MAPCAR DLIST (FUNCTION (LAMBDA (X)
(|fetch| FD |of| X)))))))))
(\\PUTREVERSEDFIXP
(LAMBDA (PTR NUM) (* \; "Edited 11-Dec-87 12:19 by N.H.Briggs")
(* |;;| "Store in completely reversed byte order")
(PROG (HI LO)
(.UNBOX. NUM HI LO)
(|replace| (FIXP LONUM) |of| PTR |with| (LOGOR (LRSH HI 8)
(LLSH (LOGAND HI 255)
8)))
(|replace| (FIXP HINUM) |of| PTR |with| (LOGOR (LRSH LO 8)
(LLSH (LOGAND LO 255)
8)))
(RETURN NUM))))
)
(* |;;| "")
(RPAQQ DATATYPEFIELDTYPES ((FLOATP 0.0)
(FIXP 0)
(SWAPPEDFIXP 0)
(REVERSEDFIXP 0)
(POINTER NIL)
(XPOINTER NIL)
(FULLPOINTER NIL)
(FULLXPOINTER NIL)
(SWAPPEDXPOINTER NIL)
(FLAG NIL)
(BYTE 0)
(WORD 0)
(REVERSEDWORD 0)
(SIGNEDWORD 0)))
(PUTPROPS DATATYPESPLUS COPYRIGHT ("Xerox Corporation" 1987 1988))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (1487 32010 (FETCHFIELD 1497 . 5916) (REPLACEFIELD 5918 . 12320) (COMPILEDFETCHFIELD
12322 . 17667) (COMPILEDREPLACEFIELD 17669 . 22035) (TRANSLATE.DATATYPE 22037 . 31268) (
\\PUTREVERSEDFIXP 31270 . 32008)))))
STOP