(FILECREATED "20-OCT-83 11:40:10" {PHYLUM}<LISPCORE>SOURCES>ADDARITH.;95 59356
changes to: (FNS \VectorREF \VectorSET \VectorLENGTH \MakeVector)
(VARS ADDARITHCOMS)
previous date: "28-SEP-83 21:14:00" {PHYLUM}<LISPCORE>SOURCES>ADDARITH.;93)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT ADDARITHCOMS)
(RPAQQ ADDARITHCOMS ((DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (P (SETQ CLISPIFTRANFLG T)))
(LOCALVARS . T)
(RECORDS RATIONAL)
(COMS (* These facilities should be common with Interlisp-10 and Interlisp-VAX)
(COMS (* Vectors are "fast" equivalents to 0-origin POINTER arrays)
(MACROS \MakeVector \VectorREF \VectorSET)
(FNS \VectorLENGTH \MakeVector \VectorREF \VectorSET))
(COMS (* Bit mask functions)
(FNS \SETUP.MASKARRAYS)
(PROP GLOBALVAR \RJ1M \MASKOUT.MARGIN)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\SETUP.MASKARRAYS)))
(MACROS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT)
(FNS \MASK.1'S.EXPANDER)
(FNS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT)
(DECLARE: DONTCOPY EVAL@COMPILE (* Grumble lossaged due to failure
of (FNS ...)
when merely EVAL@COMPILE)
(FNS \MASK.1'S.EXPANDER)))
(COMS (* BYTE hacking functions)
(RECORDS BYTESPEC)
(DECLARE: DONTCOPY (EXPORT (MACROS \CHECK.BYTESPEC \INDEXABLE.FIXP)))
(FNS LOADBYTE DEPOSITBYTE)
(MACROS LOADBYTE DEPOSITBYTE LDB DPB BYTE BYTESIZE BYTEPOSITION)
(FNS \LDBEXPANDER \DPBEXPANDER \LOADBYTEEXPANDER
\DEPOSITBYTEEXPANDER)
(DECLARE: DONTCOPY EVAL@COMPILE (* Grumble lossaged due to failure
of (FNS ...)
when merely EVAL@COMPILE)
(FNS \LOADBYTEEXPANDER \DEPOSITBYTEEXPANDER))))
(DECLARE: DONTCOPY (MACROS .HIHALFWORDLO. .HIHALFWORDHI. .LOHALFWORDLO.
.LOHALFWORDHI.)
(EXPORT (MACROS .XUNBOX. \MOVETOBOX .XLLSH. .XLRSH. .XLLSH1.
.SUMSMALLMOD. .DIFFERENCESMALLMOD.
.ADD.2WORD.INTEGERS. .SUB.2WORD.INTEGERS. .32BITMUL.)))
(COMS (* Some version of the following should be done in MACHINEDEPENDENT for
the other Interlisps.)
(GLOBALRESOURCES (\MODLESSPBOX (NCREATE (QUOTE FIXP))))
(FNS IMODLESSP IMODPLUS IMODDIFFERENCE)
(MACROS IMODPLUS IMODDIFFERENCE)
(FNS ROT)
(MACROS ROT)
(FNS \ROTexpander))
(COMS (* Primitive Functions for extracting fields as integers)
(MACROS \XLOADBYTEWORD)
(FNS \XLOADBYTE \XLOADBYTEWORD \XDEPOSITBYTE \XDEPOSITBYTEWORD \XLLSHWORD
\XLRSHWORD)
(FNS \GETBASEBITS \PUTBASEBITS \GETBASEINTEGER \PUTBASEINTEGER)
(* Primitive functions, especially needed for CommonLisp array package.)
(EXPORT (DECLARE: DONTCOPY (MACROS \GETBASEFLOATP \PUTBASEFLOATP
\GETBASEFIXP \PUTBASEFIXP
\GETBASENIBBLE \PUTBASENIBBLE
\GETBASEBIT \PUTBASEBIT)))
(FNS \GETBASEFLOATP \PUTBASEFLOATP \GETBASEFIXP \PUTBASEFIXP
\GETBASENIBBLE \PUTBASENIBBLE \GETBASEBIT \PUTBASEBIT))
(COMS (* Beginning of rewrite of some LLARITH things, modularly using the macros
of this file)
(FNS NEWTRUNCATEMULTIPLY))))
(DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD
(SETQ CLISPIFTRANFLG T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
[DECLARE: EVAL@COMPILE
(RECORD RATIONAL (NUMERATOR . DENOMINATOR)
(TYPE? (AND (LISTP DATUM)
(FIXP (CAR DATUM))
(FIXP (CDR DATUM)))))
]
(* These facilities should be common with Interlisp-10 and Interlisp-VAX)
(* Vectors are "fast" equivalents to 0-origin POINTER arrays)
(DECLARE: EVAL@COMPILE
(PUTPROPS \MakeVector DMACRO ((N)
(\ALLOCBLOCK N PTRBLOCK.GCT)))
(PUTPROPS \VectorREF DMACRO ((V I)
(\GETBASEPTR V (LLSH I 1))))
(PUTPROPS \VectorSET DMACRO ((V I VAL)
(\RPLPTR V (LLSH I 1)
VAL)))
)
(DEFINEQ
(\VectorLENGTH
(LAMBDA (X) (* JonL "20-OCT-83 10:55")
(OR (type? ARRAYBLOCK X)
(\ILLEGAL.ARG X))
(\#BLOCKDATACELLS X)))
(\MakeVector
(LAMBDA (N) (* JonL "20-OCT-83 10:52")
(\MACRO.MX (\MakeVector N))))
(\VectorREF
(LAMBDA (X I) (* JonL "20-OCT-83 11:39")
(OR (type? ARRAYBLOCK X)
(\ILLEGAL.ARG X))
(\MACRO.MX (\VectorREF X I))))
(\VectorSET
(LAMBDA (X I VAL) (* JonL "20-OCT-83 11:39")
(OR (type? ARRAYBLOCK X)
(\ILLEGAL.ARG X))
(\MACRO.MX (\VectorSET X I VAL))))
)
(* Bit mask functions)
(DEFINEQ
(\SETUP.MASKARRAYS
(LAMBDA NIL (* JonL "22-JAN-83 22:58")
(* \RJ1M is a Vector of right-justified 1's masks.
\MASKOUT.MARGIN is a 2-dim Vector of 1's masks, in all
possible alignments in a cell.)
(SETQ \RJ1M (\MakeVector (ADD1 BITS.PER.FIXP)))
(\VectorSET \RJ1M BITS.PER.FIXP -1)
(for K from 0 to (PROG1 (SUB1 BITS.PER.FIXP) (* Comment PPLossage)
)
do (\VectorSET \RJ1M K (SUB1 (LLSH 1 K))))
(SETQ \MASKOUT.MARGIN (\MakeVector (ADD1 BITS.PER.FIXP)))
(* Each element of \MASKOUT.MARGIN is a vector of masks,
where increasing indices means increasing start-position
of the mask.)
(\VectorSET \MASKOUT.MARGIN 0 \RJ1M)
(for POS from 1 to BITS.PER.FIXP bind MASKARRAY MAXFIELDSIZE
do (SETQ MAXFIELDSIZE (IDIFFERENCE BITS.PER.FIXP POS))
(SETQ MASKARRAY (\MakeVector (ADD1 MAXFIELDSIZE)))
(for K from 0 to (PROG1 MAXFIELDSIZE (* Comment PPLossage))
do (\VectorSET MASKARRAY K (LLSH (\VectorREF \RJ1M K)
POS)))
(\VectorSET \MASKOUT.MARGIN POS MASKARRAY))))
)
(PUTPROPS \RJ1M GLOBALVAR T)
(PUTPROPS \MASKOUT.MARGIN GLOBALVAR T)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\SETUP.MASKARRAYS)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS MASK.1'S MACRO (X
(\MASK.1'S.EXPANDER X)))
(PUTPROPS MASK.0'S MACRO (X
(PROG ((POSITION (CAR X))
(SIZE (CADR X))
TEM) (* This used to have a lot more in it, but I decided
that it really isn't an important function.)
(RETURN (if (AND (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
(SETQ POSITION TEM)
(SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
(SETQ SIZE TEM))
then (MASK.0'S POSITION SIZE)
else (LIST (QUOTE LOGNOT)
(LIST (QUOTE MASK.1'S)
POSITION SIZE)))))))
(PUTPROPS BITTEST MACRO ((N MASK)
(NEQ 0 (LOGAND N MASK))))
(PUTPROPS BITSET MACRO (= . LOGOR))
(PUTPROPS BITCLEAR MACRO ((X MASK)
(LOGAND X (LOGXOR -1 MASK))))
(PUTPROPS LOGNOT MACRO ((N) (LOGXOR -1 N)))
)
(DEFINEQ
(\MASK.1'S.EXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 21:10")
(PROG ((POSITION (CAR X))
(SIZE (CADR X))
TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
then (SETQ POSITION TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
then (SETQ SIZE TEM)
(\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
(RETURN (\VectorREF (\VectorREF \MASKOUT.MARGIN POSITION)
SIZE))
elseif (ZEROP POSITION)
then (RETURN (LIST (QUOTE \VectorREF)
(QUOTE \RJ1M)
SIZE))))
(RETURN (LIST (QUOTE \VectorREF)
(LIST (QUOTE \VectorREF)
(QUOTE \MASKOUT.MARGIN)
POSITION)
SIZE)))))
)
(DEFINEQ
(MASK.1'S
(LAMBDA (POSITION SIZE) (* JonL "24-OCT-82 18:13")
(* This function restricts it's arguments so that the open-coded expansion is valid for any correct set of
arguments; the open-coding cannot do coercion since the D version just does \GETBASEPTR using the input args as
indices.)
(\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
(\MACRO.MX (MASK.1'S POSITION SIZE))))
(MASK.0'S
(LAMBDA (POSITION SIZE) (* JonL "22-OCT-82 21:28")
(* FOO, so this may cons on larger numbers, but probably
this functions isn't all that important.)
(LOGNOT (APPLY* (FUNCTION MASK.1'S)
POSITION SIZE))))
(BITTEST
(LAMBDA (N MASK) (* JonL "26-FEB-83 12:36")
(\MACRO.MX (BITTEST N MASK))))
(BITSET
(LAMBDA (N MASK) (* JonL "26-FEB-83 12:37")
(\MACRO.MX (BITSET N MASK))))
(BITCLEAR
(LAMBDA (N MASK) (* JonL "26-FEB-83 12:36")
(\MACRO.MX (BITCLEAR N MASK))))
(LOGNOT
(LAMBDA (N) (* JonL "24-JUL-82 01:14")
(LOGXOR -1 N)))
)
(DECLARE: DONTCOPY EVAL@COMPILE
(* Grumble lossaged due to failure of (FNS ...) when merely EVAL@COMPILE)
(DEFINEQ
(\MASK.1'S.EXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 21:10")
(PROG ((POSITION (CAR X))
(SIZE (CADR X))
TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
then (SETQ POSITION TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
then (SETQ SIZE TEM)
(\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
(RETURN (\VectorREF (\VectorREF \MASKOUT.MARGIN POSITION)
SIZE))
elseif (ZEROP POSITION)
then (RETURN (LIST (QUOTE \VectorREF)
(QUOTE \RJ1M)
SIZE))))
(RETURN (LIST (QUOTE \VectorREF)
(LIST (QUOTE \VectorREF)
(QUOTE \MASKOUT.MARGIN)
POSITION)
SIZE)))))
)
)
(* BYTE hacking functions)
[DECLARE: EVAL@COMPILE
(TYPERECORD BYTESPEC (BYTESPEC.SIZE BYTESPEC.POSITION))
]
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \CHECK.BYTESPEC MACRO (X
(PROG ((POS (CAR X))
(SIZE (CADR X))
(LENGTHLIMIT (CADDR X))) (* Currently, this macro may only be call with "pos" and
"size" arguments as litatoms, so that they may be
"SETQ'd" in-line.)
(if (NOT (NNLITATOM POS))
then (SETERRORN 14 POS)
(ERRORX)
elseif (NOT (NNLITATOM SIZE))
then (SETERRORN 14 SIZE)
(ERRORX)
elseif (AND LENGTHLIMIT (NOT (LITATOM LENGTHLIMIT)))
then (SETERRORN 14 LENGTHLIMIT)
(ERRORX))
(RETURN (BQUOTE (PROGN (\CHECKTYPE , POS (AND (\INDEXABLE.FIXP , POS)
,@(AND LENGTHLIMIT
(BQUOTE ((ILEQ , POS , LENGTHLIMIT))))))
(\CHECKTYPE , SIZE
(AND (\INDEXABLE.FIXP , SIZE)
,@(AND LENGTHLIMIT
(BQUOTE ((ILEQ (IPLUS , POS , SIZE)
, LENGTHLIMIT))))))))))))
(PUTPROPS \INDEXABLE.FIXP MACRO (OPENLAMBDA (X)
(AND (FIXP X)
(IGEQ X 0))))
(PUTPROPS \INDEXABLE.FIXP DMACRO (OPENLAMBDA (X)
(AND (SMALLP X)
(IGEQ X 0))))
)
(* END EXPORTED DEFINITIONS)
)
(DEFINEQ
(LOADBYTE
(LAMBDA (N POS SIZE) (* JonL "28-SEP-83 21:08")
(\CHECK.BYTESPEC POS SIZE)
(PROG NIL
A (RETURN (SELECTC (NTYPX N)
(\SMALLP (\XLOADBYTEWORD N POS SIZE))
(\FIXP (\XLOADBYTE N POS SIZE))
(PROGN (SETQ N (LISPERROR "ILLEGAL ARG" N T))
(GO A)))))))
(DEPOSITBYTE
(LAMBDA (N POS SIZE VAL) (* JonL "28-SEP-83 21:08")
(* Limits set due to BITS.PER.FIXP are because we can't
create a BIGNUM answer yet.)
(\CHECK.BYTESPEC POS SIZE BITS.PER.FIXP)
(PROG (EXTENT)
A (RETURN (if (AND (SMALLP N)
(ILEQ (SETQ EXTENT (IPLUS POS SIZE))
BITSPERWORD))
then (\XDEPOSITBYTEWORD N POS SIZE VAL EXTENT)
elseif (FIXP N)
then (\XDEPOSITBYTE N POS SIZE VAL)
else (SETQ N (LISPERROR "ILLEGAL ARG" N T))
(GO A))))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS LOADBYTE MACRO (X
(\LOADBYTEEXPANDER X)))
(PUTPROPS DEPOSITBYTE MACRO (X
(\DEPOSITBYTEEXPANDER X)))
(PUTPROPS LDB MACRO (X (\LDBEXPANDER X)))
(PUTPROPS DPB MACRO (X (\DPBEXPANDER X)))
(PUTPROPS BYTE MACRO (X
(PROG ((SIZE (LISPFORM.SIMPLIFY (CAR X)
T))
(POSITION (LISPFORM.SIMPLIFY (CADR X)
T)))
(RETURN (if (AND (FIXP POSITION)
(FIXP SIZE))
then (KWOTE (create BYTESPEC
BYTESPEC.SIZE ← SIZE
BYTESPEC.POSITION ← POSITION))
else (BQUOTE (create BYTESPEC
BYTESPEC.SIZE ← , SIZE
BYTESPEC.POSITION ← , POSITION)))))))
(PUTPROPS BYTESIZE MACRO ((BYTESPEC)
(fetch BYTESPEC.SIZE of BYTESPEC)))
(PUTPROPS BYTEPOSITION MACRO ((BYTESPEC)
(fetch BYTESPEC.POSITION of BYTESPEC)))
)
(DEFINEQ
(\LDBEXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 21:10")
(PROG ((BS (LISPFORM.SIMPLIFY (CAR X)
T))
(WORD (CADR X))
TEM N SIZE POSITION)
(RETURN (if (AND (SETQ TEM (CAR (EVALUABLE.CONSTANTP BS)))
(type? BYTESPEC TEM))
then (LIST (QUOTE LOADBYTE)
WORD
(KWOTE (BYTEPOSITION TEM))
(KWOTE (BYTESIZE TEM)))
else (SETQ N (LISPFORM.SIMPLIFY WORD T))
(if (AND (LISTP BS)
(EQ (CAR BS)
(QUOTE CONS))
(EQUAL (CADR BS)
(QUOTE (QUOTE BYTESPEC)))
(LISTP (SETQ TEM (CADDR BS)))
(EQ (CAR TEM)
(QUOTE LIST)))
then (* What a crappy thing to do in order to try to
de-compile the expanded form of
(BYTE <size> <position>))
(pop TEM)
(SETQ SIZE (pop TEM))
(SETQ POSITION (pop TEM))
(if (OR (EVALUABLE.CONSTANT.FIXP N)
(AND (ARGS.COMMUTABLEP N SIZE)
(ARGS.COMMUTABLEP N POSITION)
(ARGS.COMMUTABLEP SIZE POSITION)))
then (BQUOTE (LOADBYTE , WORD , POSITION , SIZE))
else (BQUOTE ((LAMBDA (\Bytesize \Byteposition)
(DECLARE (LOCALVARS \Bytesize \Byteposition))
(LOADBYTE , WORD \Byteposition \Bytesize))
, SIZE , POSITION)))
elseif (AND (LITATOM BS)
(OR (EVALUABLE.CONSTANT.FIXP N)
(ARGS.COMMUTABLEP BS N)))
then (BQUOTE (LOADBYTE , WORD (BYTEPOSITION , BS)
(BYTESIZE , BS)))
else (BQUOTE ((LAMBDA (\PositionSize)
(DECLARE (LOCALVARS \PositionSize))
(LOADBYTE , WORD (BYTEPOSITION \PositionSize)
(BYTESIZE \PositionSize)))
, BS))))))))
(\DPBEXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 20:49")
(PROG ((NEWBYTE (CAR X))
(BS (LISPFORM.SIMPLIFY (CADR X)
T))
(WORD (LISPFORM.SIMPLIFY (CADDR X)
T))
SIZE POS X Y BagBiterP N BYTEFORM DEPOSITFORM CBSP TEM)
(if (AND (LISTP BS)
(EQ (CAR BS)
(QUOTE CONS))
(EQUAL (CADR BS)
(QUOTE (QUOTE BYTESPEC)))
(LISTP (SETQ TEM (CADDR BS)))
(EQ (CAR TEM)
(QUOTE LIST)))
then (* What a crappy thing to do in order to try to
de-compile the expanded form of
(BYTE <size> <position>))
(pop TEM)
(SETQ SIZE (pop TEM))
(SETQ POS (pop TEM))
(SETQ CBSP (AND (EVALUABLE.CONSTANTP SIZE)
(EVALUABLE.CONSTANTP POS)))
elseif (AND (SETQ TEM (CAR (EVALUABLE.CONSTANTP BS)))
(type? BYTESPEC TEM))
then (SETQ SIZE (KWOTE (BYTESIZE TEM)))
(SETQ POS (KWOTE (BYTEPOSITION TEM)))
(SETQ CBSP T))
(SETQ N (LISPFORM.SIMPLIFY NEWBYTE T))
(SETQ BagBiterP (OR (NOT (ARGS.COMMUTABLEP N WORD))
(AND (NOT CBSP)
(NOT (ARGS.COMMUTABLEP N BS)))))
(SETQ BYTEFORM (if BagBiterP
then (QUOTE \NewByte)
else NEWBYTE))
(SETQ DEPOSITFORM (if (AND SIZE POS)
then (* the SIZE and POSITION specifiers are somehow
extractable.)
(if (OR CBSP (AND (ARGS.COMMUTABLEP SIZE POS)
(ARGS.COMMUTABLEP WORD BS)))
then (* Case with a detected constant for bytespecifier)
(BQUOTE (DEPOSITBYTE , WORD , POS , SIZE , BYTEFORM))
else (BQUOTE ((LAMBDA (\Bytesize \Byteposition)
(DECLARE (LOCALVARS \Bytesize \Byteposition))
(DEPOSITBYTE , WORD \Byteposition \Bytesize ,
BYTEFORM))
, SIZE , POS)))
else (if (AND (LITATOM BS)
(ARGS.COMMUTABLEP WORD BS))
then (BQUOTE (DEPOSITBYTE , WORD (BYTEPOSITION , BS)
(BYTESIZE , BS)
, BYTEFORM))
else (SETQ BagBiterP T)
(BQUOTE ((LAMBDA (\ByteSpec)
(DECLARE (LOCALVARS \ByteSpec))
(DEPOSITBYTE , WORD (BYTEPOSITION \ByteSpec)
(BYTESIZE \ByteSpec)
\NewByte))
, BS)))))
(RETURN (if BagBiterP
then (BQUOTE ((LAMBDA (\NewByte)
(DECLARE (LOCALVARS \NewByte))
, DEPOSITFORM)
, NEWBYTE))
else DEPOSITFORM)))))
(\LOADBYTEEXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 21:10")
((LAMBDA (SIZE)
(SETQ SIZE (EVALUABLE.CONSTANT.FIXP (CADDR X)))
(if (NULL SIZE)
then ((LAMBDA (POS)
(if POS
then (BQUOTE (LOGAND (LRSH , (CAR X)
, POS)
(MASK.1'S 0 , (CADDR X))))
else (QUOTE IGNOREMACRO)))
(EVALUABLE.CONSTANT.FIXP (CADR X)))
else (if (OR (NOT (\INDEXABLE.FIXP SIZE))
(NOT (IGEQ SIZE 0)))
then (ERROR (CADDR X)
"Byte size out of range"))
(if (ZEROP SIZE)
then (LIST (QUOTE PROGN)
(CAR X)
(CADR X)
0)
else (PROG ((WORD (CAR X))
(POS (CADR X))
(MASK (if (ILEQ SIZE BITS.PER.FIXP)
then (MASK.1'S 0 SIZE)
else (BITCLEAR -1 (LLSH -1 SIZE))))
TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP POS))
then (* The position is constant)
(if (OR (NOT (\INDEXABLE.FIXP TEM))
(NOT (IGEQ TEM 0)))
then (ERROR POS "Byte position out of range"))
(SETQ POS TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP WORD))
then (RETURN (LOADBYTE TEM POS SIZE))))
(RETURN (LIST (QUOTE LOGAND)
(if (ZEROP POS)
then WORD
else (LIST (QUOTE LRSH)
WORD POS))
MASK)))))))))
(\DEPOSITBYTEEXPANDER
(LAMBDA (X) (* JonL "28-SEP-83 21:10")
((LAMBDA (POS SIZE)
(if (AND SIZE (ILEQ SIZE 0))
then (if (ZEROP SIZE)
then (LIST (QUOTE PROG1)
(CAR X)
(CADR X)
(CADDDR X))
else (ERROR (CADDR X)
"Byte size out of range"))
elseif (AND POS (ILESSP POS 0))
then (ERROR (CADR X)
"Byte position out of range")
elseif (OR (NULL SIZE)
(NULL POS)
(SELECTQ (SYSTEMTYPE)
(D (ILESSP BITSPERCELL (IPLUS POS SIZE)))
NIL))
then (* Unless both Position and Size are constant, then the
open-coded formula has too much likelihood of CONSing)
(QUOTE IGNOREMACRO)
elseif (ILESSP BITSPERWORD (IPLUS POS SIZE))
then (* For D machines, if the constant byte isn't wholly
contained within a word-sized number, then again there
is too much likelihood of CONSing)
(CONS (QUOTE \XDEPOSITBYTE)
X)
else (PROG ((WORD (CAR X))
(VAL (CADDDR X))
(MASK (if (ILEQ SIZE BITS.PER.FIXP)
then (MASK.1'S 0 SIZE)
else (BITCLEAR -1 (LLSH -1 SIZE))))
NWORD NVAL)
(SETQ NWORD (EVALUABLE.CONSTANT.FIXP WORD))
(AND (SETQ NVAL (EVALUABLE.CONSTANT.FIXP VAL))
(SETQ NVAL (LOGAND NVAL MASK)))
(RETURN (if (AND NWORD NVAL)
then (\XDEPOSITBYTE NWORD POS SIZE NVAL)
elseif NWORD
then (* So VAL is now know not to be numeric
(or else the preceeding clause would have been taken))
((LAMBDA (SHIFTEDVAL)
(if (NEQ POS 0)
then (SETQ SHIFTEDVAL (LIST (QUOTE LLSH)
SHIFTEDVAL POS)))
(if (ZEROP (SETQ NWORD (BITCLEAR NWORD (LLSH MASK POS))))
then SHIFTEDVAL
else (LIST (QUOTE LOGOR)
NWORD SHIFTEDVAL)))
(LIST (QUOTE LOGAND)
VAL MASK))
else ((LAMBDA (MWORD)
(if (AND NVAL (ZEROP (SETQ NVAL (LOGAND NVAL MASK))))
then (* Depositing a byte of 0's)
MWORD
elseif (AND NVAL (EQ MASK NVAL))
then (* Depositing a byte of 1'S)
(CONS (QUOTE BITSET)
(CDR MWORD))
else (if NVAL
then (SETQ VAL (LLSH NVAL POS))
else (SETQ VAL (BQUOTE (LOGAND , VAL , MASK)))
(if (NOT (ZEROP POS))
then (SETQ VAL (LIST (QUOTE LLSH)
VAL POS))))
(BQUOTE (LOGOR , MWORD , VAL))))
(BQUOTE (BITCLEAR , WORD , (LLSH MASK POS)))))))))
(EVALUABLE.CONSTANT.FIXP (CADR X))
(EVALUABLE.CONSTANT.FIXP (CADDR X)))))
)
(DECLARE: DONTCOPY EVAL@COMPILE
(* Grumble lossaged due to failure of (FNS ...) when merely EVAL@COMPILE)
(DEFINEQ
(\LOADBYTEEXPANDER
(LAMBDA (X) (* JonL "25-FEB-83 21:10")
((LAMBDA (SIZE)
(SETQ SIZE (EVALUABLE.CONSTANT.FIXP (CADDR X)))
(if (NULL SIZE)
then ((LAMBDA (POS)
(if POS
then (BQUOTE (LOGAND (LRSH , (CAR X)
, POS)
(MASK.1'S 0 , (CADDR X))))
else (QUOTE IGNOREMACRO)))
(EVALUABLE.CONSTANT.FIXP (CADR X)))
else (if (OR (NOT (\INDEXABLE.FIXP SIZE))
(NOT (IGEQ SIZE 0)))
then (ERROR (CADDR X)
"Byte size out of range"))
(if (ZEROP SIZE)
then (LIST (QUOTE PROGN)
(CAR X)
(CADR X)
0)
else (PROG ((WORD (CAR X))
(POS (CADR X))
(MASK (if (ILEQ SIZE BITS.PER.FIXP)
then (MASK.1'S 0 SIZE)
else (BITCLEAR -1 (LLSH -1 SIZE))))
TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP POS))
then (* The position is constant)
(if (OR (NOT (\INDEXABLE.FIXP TEM))
(NOT (IGEQ TEM 0)))
then (ERROR POS "Byte position out of range"))
(SETQ POS TEM)
(if (SETQ TEM (EVALUABLE.CONSTANT.FIXP WORD))
then (RETURN (LOADBYTE TEM POS SIZE))))
(RETURN (LIST (QUOTE LOGAND)
(if (ZEROP POS)
then WORD
else (LIST (QUOTE LRSH)
WORD POS))
MASK)))))))))
(\DEPOSITBYTEEXPANDER
(LAMBDA (X) (* JonL "28-SEP-83 21:10")
((LAMBDA (POS SIZE)
(if (AND SIZE (ILEQ SIZE 0))
then (if (ZEROP SIZE)
then (LIST (QUOTE PROG1)
(CAR X)
(CADR X)
(CADDDR X))
else (ERROR (CADDR X)
"Byte size out of range"))
elseif (AND POS (ILESSP POS 0))
then (ERROR (CADR X)
"Byte position out of range")
elseif (OR (NULL SIZE)
(NULL POS)
(SELECTQ (SYSTEMTYPE)
(D (ILESSP BITSPERCELL (IPLUS POS SIZE)))
NIL))
then (* Unless both Position and Size are constant, then the
open-coded formula has too much likelihood of CONSing)
(QUOTE IGNOREMACRO)
elseif (ILESSP BITSPERWORD (IPLUS POS SIZE))
then (* For D machines, if the constant byte isn't wholly
contained within a word-sized number, then again there
is too much likelihood of CONSing)
(CONS (QUOTE \XDEPOSITBYTE)
X)
else (PROG ((WORD (CAR X))
(VAL (CADDDR X))
(MASK (if (ILEQ SIZE BITS.PER.FIXP)
then (MASK.1'S 0 SIZE)
else (BITCLEAR -1 (LLSH -1 SIZE))))
NWORD NVAL)
(SETQ NWORD (EVALUABLE.CONSTANT.FIXP WORD))
(AND (SETQ NVAL (EVALUABLE.CONSTANT.FIXP VAL))
(SETQ NVAL (LOGAND NVAL MASK)))
(RETURN (if (AND NWORD NVAL)
then (\XDEPOSITBYTE NWORD POS SIZE NVAL)
elseif NWORD
then (* So VAL is now know not to be numeric
(or else the preceeding clause would have been taken))
((LAMBDA (SHIFTEDVAL)
(if (NEQ POS 0)
then (SETQ SHIFTEDVAL (LIST (QUOTE LLSH)
SHIFTEDVAL POS)))
(if (ZEROP (SETQ NWORD (BITCLEAR NWORD (LLSH MASK POS))))
then SHIFTEDVAL
else (LIST (QUOTE LOGOR)
NWORD SHIFTEDVAL)))
(LIST (QUOTE LOGAND)
VAL MASK))
else ((LAMBDA (MWORD)
(if (AND NVAL (ZEROP (SETQ NVAL (LOGAND NVAL MASK))))
then (* Depositing a byte of 0's)
MWORD
elseif (AND NVAL (EQ MASK NVAL))
then (* Depositing a byte of 1'S)
(CONS (QUOTE BITSET)
(CDR MWORD))
else (if NVAL
then (SETQ VAL (LLSH NVAL POS))
else (SETQ VAL (BQUOTE (LOGAND , VAL , MASK)))
(if (NOT (ZEROP POS))
then (SETQ VAL (LIST (QUOTE LLSH)
VAL POS))))
(BQUOTE (LOGOR , MWORD , VAL))))
(BQUOTE (BITCLEAR , WORD , (LLSH MASK POS)))))))))
(EVALUABLE.CONSTANT.FIXP (CADR X))
(EVALUABLE.CONSTANT.FIXP (CADDR X)))))
)
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS .HIHALFWORDLO. MACRO ((X)
(LRSH X BITSPERHALFWORD)))
(PUTPROPS .HIHALFWORDHI. MACRO ((X)
(LOGAND X (CONSTANT (LSH MASKHALFWORD1'S BITSPERHALFWORD)))))
(PUTPROPS .LOHALFWORDLO. MACRO ((X)
(LOGAND X MASKHALFWORD1'S)))
(PUTPROPS .LOHALFWORDHI. MACRO ((X)
(LLSH (LOGAND X MASKHALFWORD1'S)
BITSPERHALFWORD)))
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS .XUNBOX. MACRO ((X HX LX)
(until (SETQ LX (SELECTC (NTYPX X)
(\SMALLP (COND
((SMALLPOSP X)
(SETQ HX 0)
X)
(T (SETQ HX MASKWORD1'S)
(LOLOC X))))
(\FIXP (SETQ HX (fetch (FIXP HINUM) of X))
(fetch (FIXP LONUM) of X))
NIL))
do (SETQ X (LISPERROR "ILLEGAL ARG" X T)))))
(PUTPROPS \MOVETOBOX DMACRO (OPENLAMBDA (N D)
(SELECTC (NTYPX N)
(\SMALLP (replace (FIXP HINUM) of D with 0)
(replace (FIXP LONUM) of D with N))
(\FIXP (replace (FIXP HINUM) of D with (fetch (FIXP HINUM) of N))
(replace (FIXP LONUM) of D with (fetch (FIXP LONUM) of N)))
(\ILLEGAL.ARG N))))
(PUTPROPS .XLLSH. MACRO ((HI LO N)
(if (IGEQ N BITSPERWORD)
then (* Jump 10 bits in a single bound!)
(SETQ HI LO)
(SETQ LO 0)
(SETQ N (IDIFFERENCE N BITSPERWORD)))
(if (IGEQ N BITSPERHALFWORD)
then (* Jump 8 bits in a single bound!)
(SETQ HI (LOGOR (.LOHALFWORDHI. HI)
(.HIHALFWORDLO. LO)))
(SETQ LO (.LOHALFWORDHI. LO))
(SETQ N (IDIFFERENCE N BITSPERHALFWORD)))
(if (IGEQ N 4)
then (* Jump 4 bits in a single bound!)
(SETQ HI (LOGOR (LRSH LO (CONSTANT (IDIFFERENCE BITSPERWORD 4)))
(LLSH (LOGAND HI (CONSTANT (MASK.1'S 0 (IDIFFERENCE BITSPERWORD 4))))
4)))
(SETQ LO (LLSH (LOGAND LO (CONSTANT (MASK.1'S 0 (IDIFFERENCE BITSPERWORD 4))))
4))
(SETQ N (IDIFFERENCE N 4))) (* MASK0WORD1'S should be same as
(SUB1 (LSH 1 (SUB1 BITSPERWORD))))
(FRPTQ N (SETQ HI (LLSH (LOGAND HI MASK0WORD1'S)
1))
(SETQ LO (LLSH (if (IGEQ LO MASK1WORD0'S)
then (add HI 1)
(LOGAND LO MASK0WORD1'S)
else LO)
1)))))
(PUTPROPS .XLRSH. MACRO ((HI LO N)
(if (IGEQ N BITSPERWORD)
then (* Jump 10 bits in a single bound!)
(SETQ LO HI)
(SETQ HI 0)
(SETQ N (IDIFFERENCE N BITSPERWORD)))
(if (IGEQ N BITSPERHALFWORD)
then (* Jump 8 bits in a single bound!)
(SETQ LO (LOGOR (.HIHALFWORDLO. LO)
(.LOHALFWORDHI. HI)))
(SETQ HI (.HIHALFWORDLO. HI))
(SETQ N (IDIFFERENCE N BITSPERHALFWORD)))
(if (IGEQ N 4)
then (* Jump 4 bits in a single bound!)
(SETQ LO (LOGOR (LLSH (LOGAND HI (CONSTANT (MASK.1'S 0 4)))
(CONSTANT (IDIFFERENCE BITSPERWORD 4)))
(LRSH LO 4)))
(SETQ HI (LRSH HI 4))
(SETQ N (IDIFFERENCE N 4))) (* MASK1WORD0'S should be same as \SIGNBIT)
(FRPTQ N (SETQ LO (if (ODDP HI)
then (LOGOR (LRSH LO 1)
MASK1WORD0'S)
else (LRSH LO 1)))
(SETQ HI (LRSH HI 1)))))
(PUTPROPS .XLLSH1. MACRO ((HI LO)
(PROGN (SETQ HI (LLSH (LOGAND HI MASK0WORD1'S)
1))
(SETQ LO (LSH (COND
((IGEQ LO MASK1WORD0'S)
(SETQ HI (LOGOR HI 1))
(LOGAND LO MASK0WORD1'S))
(T LO))
1)))))
(PUTPROPS .SUMSMALLMOD. MACRO ((X Y OVERFLOWFORM)
((LAMBDA (\SumSmallModVar)
(DECLARE (LOCALVARS \SumSmallModVar))
(IF (ILEQ X \SumSmallModVar)
THEN (IPLUS X Y)
ELSE OVERFLOWFORM (IDIFFERENCE X (ADD1 \SumSmallModVar))))
(IDIFFERENCE MAX.SMALL.INTEGER Y))))
(PUTPROPS .DIFFERENCESMALLMOD. MACRO ((X Y BORROWFORM)
(IF (NOT (IGREATERP Y X))
THEN (IDIFFERENCE X Y)
ELSE BORROWFORM (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X))))))
(PUTPROPS .ADD.2WORD.INTEGERS. MACRO ((HX LX HY LY)
(* Ignores carry out of high-order word)
(SETQ HX (.SUMSMALLMOD. HX HY))
(SETQ LX (.SUMSMALLMOD. LX LY (SETQ HX (if (EQ HX MAX.SMALL.INTEGER)
then 0
else (ADD1 HX)))))))
(PUTPROPS .SUB.2WORD.INTEGERS. MACRO ((HX LX HY LY)
(* Ignores carry out of high-order word)
(SETQ HX (.DIFFERENCESMALLMOD. HX HY))
(SETQ LX (.DIFFERENCESMALLMOD. LX LY (SETQ HX (if (EQ HX 0)
then MAX.SMALL.INTEGER
else (SUB1 HX)))))))
(PUTPROPS .32BITMUL. MACRO ((HR LR X Y)
(PROG (HX LX HY LY)
(if (ILESSP X Y)
then (swap X Y)) (* Y is the lesser of the two now)
(.XUNBOX. X HX LX)
(.XUNBOX. Y HY LY)
LP (if (ODDP LY)
then (.ADD.2WORD.INTEGERS. HR LR HX LX))
(if (EQ HY 0)
then (SETQ LY (LRSH LY 1))
(if (EQ LY 0)
then (RETURN))
else (.LRSH1. HY LY)) (* Trim off highest bits, so that left-shifting doesn't
generate FIXPs)
(SETQ HX (LOGAND HX MASK0WORD1'S))
(.LLSH1. HX LX)
(GO LP))))
)
(* END EXPORTED DEFINITIONS)
)
(* Some version of the following should be done in MACHINEDEPENDENT for the other Interlisps.)
(RPAQQ \MODLESSPBOX NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \MODLESSPBOX)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \MODLESSPBOX)
(QUOTE GLOBALRESOURCES)
(QUOTE (NCREATE (QUOTE FIXP))))
)
(DEFINEQ
(IMODLESSP
(LAMBDA (X Y MODULUS EQUAL?) (* JonL "21-NOV-82 15:58")
(if (AND EQUAL? (EQ X Y))
then (* Merely a fail-safe heuristic.)
T
elseif (OR (EQ MODULUS (QUOTE WORD))
(AND (FIXP MODULUS)
(IGEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD)))
(ILEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD)))))
then (OR (SMALLP (SETQ X (IDIFFERENCE Y X)))
(SETQ X (fetch (FIXP LONUM) of X)))
(if (ZEROP X)
then EQUAL?
else (ILESSP X (CONSTANT (EXPT 2 (SUB1 BITSPERWORD)))))
elseif (OR (EQ MODULUS (QUOTE CELL))
(AND (FIXP MODULUS)
(POWEROFTWOP MODULUS)))
then ((LAMBDA (TEMPY)
(\MOVETOBOX Y TEMPY)
(\BOXIDIFFERENCE TEMPY X)
(if (AND (ZEROP (fetch (FIXP HINUM) of TEMPY))
(ZEROP (fetch (FIXP LONUM) of TEMPY)))
then EQUAL?
elseif (EQ MODULUS (QUOTE CELL))
then (IGREATERP TEMPY 0)
elseif (SMALLP MODULUS)
then (if (ZEROP (SETQ X (LOGAND TEMPY (SUB1 MODULUS))))
then EQUAL?
else (ILESSP X (LRSH MODULUS 1)))
else (PROG ((DIV (SUB1 (INTEGERLENGTH MODULUS))))
(RETURN (if (ZEROP (SETQ X (LOGAND TEMPY (MASK.1'S 0 DIV))))
then EQUAL?
else (ILESSP X (MASK.1'S (SUB1 DIV)
1)))))))
(CREATECELL \FIXP))
else (ILESSP (IMOD (DIFFERENCE Y X)
MODULUS)
(FOLDHI MODULUS 2)))))
(IMODPLUS
(LAMBDA (X Y MODULUS) (* JonL "21-NOV-82 16:05")
(PROG NIL
A (SELECTC (NTYPX MODULUS)
(\LITATOM (SELECTQ MODULUS
(WORD (RETURN (.SUMSMALLMOD. (\LONUM X)
(\LONUM Y))))
(CELL (RETURN ((LAMBDA (\OVERFLOW)
(IPLUS X Y))
0)))
NIL))
((LIST \FIXP \SMALLP)
(AND (IGREATERP MODULUS 0)
(if (AND (IGEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD)))
(ILEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD))))
then (SETQ MODULUS (QUOTE WORD))
(GO A)
else (RETURN ((LAMBDA (TEMPX)
(\MOVETOBOX X TEMPX)
(\BOXIPLUS TEMPX Y)
(IMOD TEMPX MODULUS))
(CREATECELL \FIXP))))))
NIL)
(SETQ MODULUS (LISPERROR "ILLEGAL ARG" MODULUS T))
(GO A))))
(IMODDIFFERENCE
(LAMBDA (X Y MODULUS) (* JonL "21-NOV-82 16:05")
(PROG NIL
A (SELECTC (NTYPX MODULUS)
(\LITATOM (SELECTQ MODULUS
(WORD (RETURN (.DIFFERENCESMALLMOD. (\LONUM X)
(\LONUM Y))))
(CELL (RETURN ((LAMBDA (\OVERFLOW)
(IDIFFERENCE X Y))
0)))
NIL))
((LIST \FIXP \SMALLP)
(AND (IGREATERP MODULUS 0)
(if (AND (IGEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD)))
(ILEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD))))
then (SETQ MODULUS (QUOTE WORD))
(GO A)
else (RETURN ((LAMBDA (TEMPX)
(\MOVETOBOX X TEMPX)
(\BOXIDIFFERENCE TEMPX Y)
(IMOD TEMPX MODULUS))
(CREATECELL \FIXP))))))
NIL)
(SETQ MODULUS (LISPERROR "ILLEGAL ARG" MODULUS T))
(GO A))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS IMODPLUS DMACRO (L
(PROG ((X (CAR L))
(Y (CADR L))
(MODULUS (CADDR L)))
(AND (CONSTANTEXPRESSIONP MODULUS)
(EQ (SETQ MODULUS (EVAL MODULUS))
(QUOTE CELL))
(RETURN (SUBLIS (LIST (CONS (QUOTE X)
X)
(CONS (QUOTE Y)
Y))
(QUOTE ((LAMBDA (\OVERFLOW)
(IPLUS X Y))
0)))))
(RETURN (QUOTE IGNOREMACRO)))))
(PUTPROPS IMODDIFFERENCE DMACRO (L
(PROG ((X (CAR L))
(Y (CADR L))
(MODULUS (CADDR L)))
(AND (CONSTANTEXPRESSIONP MODULUS)
(EQ (SETQ MODULUS (EVAL MODULUS))
(QUOTE CELL))
(RETURN (SUBLIS (LIST (CONS (QUOTE X)
X)
(CONS (QUOTE Y)
Y))
(QUOTE ((LAMBDA (\OVERFLOW)
(IDIFFERENCE X Y))
0)))))
(RETURN (QUOTE IGNOREMACRO)))))
)
(DEFINEQ
(ROT
(LAMBDA (X N FIELDSIZE) (* JonL "29-JAN-83 00:13")
(SETQ N (\DTEST N (QUOTE SMALLP)))
(until (FIXP X) do (SETQ X (LISPERROR "ILLEGAL ARG" X T)))
(PROG NIL
A (if (AND (SMALLP FIELDSIZE)
(IGREATERP FIELDSIZE 0)
(ILEQ FIELDSIZE BITSPERCELL))
then (SETQ N (IMOD N FIELDSIZE))
(RETURN)
else (SELECTQ FIELDSIZE
((WORD)
(SETQ FIELDSIZE BITSPERWORD)
(GO A))
((CELL NIL)
(SETQ FIELDSIZE BITSPERCELL)
(GO A))
NIL))
(SETQ FIELDSIZE (LISPERROR "ILLEGAL ARG" FIELDSIZE T))
(GO A))
(* Note that N, the shifting factor, has been normalized into the half-open interval of 0 to FIELDSIZE and a
negative N (rotating rightwards) has been transformed into a positive form.)
(if (EQ N 0)
then X
else (PROG ((N.B (IDIFFERENCE FIELDSIZE N)))
(RETURN (if (ILEQ FIELDSIZE BITSPERWORD)
then (SETQ X (LOGAND X (CONSTANT (MASK.1'S 0 BITSPERWORD))))
(\XDEPOSITBYTEWORD (\XLOADBYTEWORD X N.B N)
N N.B X)
else (DEPOSITBYTE (LOADBYTE X N.B N)
N N.B X)))))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS ROT DMACRO (L (\ROTexpander L)))
)
(DEFINEQ
(\ROTexpander
(LAMBDA (L) (* JonL "25-FEB-83 21:10")
(* WARNING! WARNING! Note that the value for BITSPERWORD is bound at the time of compiling this function, and this
determines the range of utility of the ROT macro (maybe there is some MAKEINIT problem here?))
(PROG ((X (CAR L))
(N (CADR L))
(WORDSIZE (CAR (EVALUABLE.CONSTANTP (CADDR L))))
TEM)
(if (AND (OR (FIXP WORDSIZE)
(if (EQ WORDSIZE (QUOTE WORD))
then (SETQ WORDSIZE BITSPERWORD)
T))
(SETQ N (EVALUABLE.CONSTANT.FIXP N)))
then (if (SETQ TEM (EVALUABLE.CONSTANT.FIXP X))
then (RETURN (ROT TEM N WORDSIZE))
elseif (AND (EQ WORDSIZE BITSPERWORD)
(EQ 1 N))
then (RETURN (BQUOTE ((LAMBDA (\Xtested)
(DECLARE (LOCALVARS \Xtested))
((LAMBDA (\Xbitoff)
(DECLARE (LOCALVARS \Xbitoff))
(if (EQ \Xtested \Xbitoff)
then (LLSH \Xbitoff 1)
else (LOGOR 1 (LLSH \Xbitoff 1))))
(LOGAND \Xtested , (MASK.1'S 0 (SUB1 BITSPERWORD))))
)
(LOGAND , X , (MASK.1'S 0 BITSPERWORD)))))))
(RETURN (QUOTE IGNOREMACRO)))))
)
(* Primitive Functions for extracting fields as integers)
(DECLARE: EVAL@COMPILE
(PUTPROPS \XLOADBYTEWORD DMACRO ((N POS SIZE)
(* N is constrained to be a SMALLP)
(LOGAND (\XLRSHWORD N POS)
(MASK.1'S 0 (IMIN BITSPERWORD SIZE)))))
)
(DEFINEQ
(\XLOADBYTE
(LAMBDA (N POS SIZE) (* JonL "28-OCT-82 22:30")
(* No error checking)
(if (IGREATERP SIZE BITSPERCELL)
then (SETQ SIZE BITSPERCELL))
(if (IGEQ POS BITSPERCELL)
then 0
else (PROG ((M (MASK.1'S 0 SIZE))
NHI NLO MHI MLO)
(.XUNBOX. N NHI NLO)
(.XUNBOX. M MHI MLO)
(.XLRSH. NHI NLO POS)
(RETURN (\MAKENUMBER (LOGAND NHI MHI)
(LOGAND NLO MLO)))))))
(\XLOADBYTEWORD
(LAMBDA (N POS SIZE) (* JonL "14-JAN-83 20:33")
(* N is constrained to be a SMALLP)
(\MACRO.MX (\XLOADBYTEWORD N POS SIZE))))
(\XDEPOSITBYTE
(LAMBDA (N POS SIZE V) (* JonL "28-OCT-82 22:13")
(* No error checking but caller MUST certify that
(IGEQ BITSPERCELL (IPLUS POS SIZE)))
(PROG ((M (MASK.1'S POS SIZE))
MHI MLO NHI NLO VHI VLO)
(.XUNBOX. M MHI MLO)
(.XUNBOX. V VHI VLO) (* Move value byte over to correct position, and trim it
to size)
(.XLLSH. VHI VLO POS)
(SETQ VHI (LOGAND VHI MHI))
(SETQ VLO (LOGAND VLO MLO)) (* Cut a "hole" in original number at selected byte)
(.XUNBOX. N NHI NLO)
(SETQ NHI (LOGAND NHI (LOGXOR MASKWORD1'S MHI)))
(SETQ NLO (LOGAND NLO (LOGXOR MASKWORD1'S MLO)))
(RETURN (\MAKENUMBER (LOGOR NHI VHI)
(LOGOR NLO VLO))))))
(\XDEPOSITBYTEWORD
(LAMBDA (N POS SIZE V EXTENT) (* JonL "17-JAN-83 12:15")
(* N, and result, constrained to be a SMALLP)
(* No error checking but caller MUST certify that
(IGEQ BITSPERWORD (IPLUS POS SIZE)))
(if (ILESSP BITSPERWORD (OR EXTENT (SETQ EXTENT (IPLUS POS SIZE))))
then (SHOULDNT)
else (PROG ((WORD (BITCLEAR N (MASK.1'S POS SIZE)))
(NEWBYTE (LOGAND V (MASK.1'S 0 SIZE))))
(RETURN (LOGOR WORD (if (EQ POS 0)
then (* Worth optimizing this case)
NEWBYTE
else (\XLLSHWORD NEWBYTE POS))))))))
(\XLLSHWORD
(LAMBDA (N POS) (* JonL " 1-OCT-82 22:47")
(* Fast Logical Left SHift, where arg and result are
both SMALLP's)
(if (IGEQ POS (CONSTANT BITSPERHALFWORD))
then (SETQ N (LLSH N (CONSTANT BITSPERHALFWORD)))
(SETQ POS (IDIFFERENCE POS (CONSTANT BITSPERHALFWORD))))
(* At this point, POS is strictly less than 8)
(if (IGEQ POS 4)
then (SETQ N (LLSH N 4))
(SETQ POS (IDIFFERENCE POS 4))) (* At this point, POS is strictly less than 4)
(if (ILESSP POS 2)
then (COND
((ILESSP POS 1)
N)
(T (LLSH N 1)))
elseif (ILESSP POS 4)
then (COND
((ILESSP POS 3)
(LLSH N 2))
(T (LLSH N 3)))
elseif (EQP N 0)
then 0
else (* (FRPTQ POS (SETQ N (LLSH N 1))))
(SHOULDNT))))
(\XLRSHWORD
(LAMBDA (N POS) (* JonL " 1-OCT-82 22:49")
(* Fast Logical Right SHift, where arg and result are
both SMALLP's)
(if (IGEQ POS BITSPERWORD)
then 0
else (if (IGEQ POS (CONSTANT BITSPERHALFWORD))
then (SETQ N (LRSH N (CONSTANT BITSPERHALFWORD)))
(SETQ POS (IDIFFERENCE POS (CONSTANT BITSPERHALFWORD))))
(* At this point, POS is strictly less than 8)
(if (IGEQ POS 4)
then (SETQ N (LRSH N 4))
(SETQ POS (IDIFFERENCE POS 4))) (* At this point, POS is strictly less than 4)
(if (ILESSP POS 2)
then (COND
((ILESSP POS 1)
N)
(T (LRSH N 1)))
elseif (ILESSP POS 4)
then (COND
((ILESSP POS 3)
(LRSH N 2))
(T (LRSH N 3)))
else (* (FRPTQ POS (SETQ N (LRSH N 1))))
(SHOULDNT)))))
)
(DEFINEQ
(\GETBASEBITS
(LAMBDA (ADDR POSITION SIZE) (* JonL "28-OCT-82 22:13")
(PROG ((WORDNO (FOLDLO POSITION BITSPERWORD))
(WSPLIT.BITNO (IMOD POSITION BITSPERWORD))
W1 LASTBITNO)
(SETQ ADDR (\ADDBASE ADDR WORDNO))
(SETQ W1 (\GETBASE ADDR 0))
(SETQ LASTBITNO (IPLUS SIZE WSPLIT.BITNO -1))
(RETURN (COND
((ILESSP LASTBITNO BITSPERWORD)
(\XLOADBYTEWORD W1 (IDIFFERENCE (CONSTANT (SUB1 BITSPERWORD))
LASTBITNO)
SIZE))
(T (PROG ((NBITS.W1 (IDIFFERENCE BITSPERWORD WSPLIT.BITNO))
(W2 (\GETBASE ADDR 1))
W1SUBBYTE NW2)
(RETURN (COND
((ILEQ SIZE BITSPERWORD)
(SETQ NW2 (IDIFFERENCE SIZE NBITS.W1))
(* NW2 here holds the number of left-justified bits
taken from the second word)
(\XDEPOSITBYTEWORD (\XLOADBYTEWORD W2 (IDIFFERENCE
BITSPERWORD NW2)
NW2)
NW2 NBITS.W1 W1))
((ILESSP LASTBITNO (CONSTANT (TIMES 2 BITSPERWORD)))
(* Byte is larger than one word, and is taken from parts
of only two words.)
(SETQ NW2 (IDIFFERENCE (CONSTANT (SUB1 (TIMES 2 BITSPERWORD))
)
LASTBITNO))
(* NW2 here is No. of "wasted" bits in word 2)
(SETQ W1SUBBYTE (\XLOADBYTEWORD W1 NW2 (IDIFFERENCE SIZE
BITSPERWORD)))
(.XLRSH. W1 W2 NW2)
(* Someday, try to replace this .XLRSH.
code using LOGOR, \XLLSHWORD and \XLRSHWORD)
(\MAKENUMBER W1SUBBYTE W2))
(T (* Sigh, from parts of three words.)
(SETQ NW2 (IDIFFERENCE (CONSTANT (SUB1 (TIMES 3 BITSPERWORD)
))
LASTBITNO))
(* No. of wasted bits on the right of the third word)
(SETQ WSPLIT.BITNO (IDIFFERENCE (CONSTANT BITSPERWORD)
NW2))
(* Here WSPLIT.BITNO holds the number of left-justified
bits taken from word 3, and also is relevalt to the
split-up of word 2)
(SETQ W1SUBBYTE (\XDEPOSITBYTEWORD
(\XLRSHWORD W2 NW2)
WSPLIT.BITNO
(IDIFFERENCE (IPLUS SIZE NW2)
(CONSTANT (TIMES 2 BITSPERWORD)))
W1))
(SETQ W1 (\GETBASE ADDR 2))
(* W1 now holds "W3", the third word)
(.XLLSH. W2 W1 WSPLIT.BITNO)
(* Someday, try to replace this .XLLSH.
using LOGOR, \XLLSHWORD and \XLRSHWORD)
(\MAKENUMBER W1SUBBYTE W2)))))))))))
(\PUTBASEBITS
(LAMBDA (ADDR POSITION SIZE VAL) (* JonL "14-OCT-82 10:31")
(PROG ((WORDNO (FOLDLO POSITION BITSPERWORD))
(WSPLIT.BITNO (IMOD POSITION BITSPERWORD))
W1 LASTBITNO)
(SETQ ADDR (\ADDBASE ADDR WORDNO))
(SETQ W1 (\GETBASE ADDR 0))
(SETQ LASTBITNO (IPLUS SIZE WSPLIT.BITNO -1))
(COND
((ILESSP LASTBITNO BITSPERWORD)
(\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD W1 (IDIFFERENCE (CONSTANT (SUB1 BITSPERWORD))
LASTBITNO)
SIZE
(OR (SMALLP VAL)
(\LONUM VAL)))))
(T (PROG ((NBITS.W1 (IDIFFERENCE BITSPERWORD WSPLIT.BITNO))
(W2 (\GETBASE ADDR 1))
NW2 NBITS.W2 VHI VLO)
(.XUNBOX. VAL VHI VLO)
(COND
((ILEQ SIZE BITSPERWORD)
(SETQ NBITS.W2 (IDIFFERENCE SIZE NBITS.W1))
(\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD W1 0 NBITS.W1 (\XLRSHWORD VLO NBITS.W2)))
(\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD W2 (IDIFFERENCE BITSPERWORD NBITS.W2)
NBITS.W2 VLO)))
((ILESSP LASTBITNO (CONSTANT (TIMES 2 BITSPERWORD)))
(* Byte is larger than one word, and is put into parts
of only two words.)
(SETQ NW2 (IDIFFERENCE (CONSTANT (SUB1 (TIMES 2 BITSPERWORD)))
LASTBITNO))
(* NW2 here is No. of "wasted" bits in word 2)
(SETQ NBITS.W2 (IDIFFERENCE SIZE NBITS.W1))
(\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD W2 NW2 NBITS.W2 VLO))
(SETQ VHI (\XDEPOSITBYTEWORD (\XLRSHWORD VLO NBITS.W2)
NBITS.W2
(IDIFFERENCE SIZE BITSPERWORD)
VHI))
(* Foo, do the SETQ only because PP can't hac it
otherwise!)
(\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD W1 0 NBITS.W1 VHI)))
(T (* Sigh, into parts of three words.)
(SETQ NW2 (IDIFFERENCE (CONSTANT (SUB1 (TIMES 3 BITSPERWORD)))
LASTBITNO))
(* No. of wasted bits on the right of the third word)
(SETQ NBITS.W2 (IDIFFERENCE (CONSTANT BITSPERWORD)
NW2))
(* Here NBITS.W2 holds the number of left-justified bits
put into word 3, and also is relevalt to the split-up of
word 2)
(\PUTBASE ADDR 2 (\XDEPOSITBYTEWORD (\GETBASE ADDR 2)
NW2 NBITS.W2 VLO))
(\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD (\XLRSHWORD VLO NBITS.W2)
NW2 NBITS.W2 VHI))
(\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD (\GETBASE ADDR 0)
0
(IDIFFERENCE SIZE (IPLUS BITSPERWORD
NBITS.W2))
(\XLRSHWORD VHI NBITS.W2)))))))))
VAL))
(\GETBASEINTEGER
(LAMBDA (ADDR POSITION SIZE) (* JonL "28-OCT-82 22:14")
(PROG ((WORDNO (FOLDLO POSITION BITSPERWORD))
(LOBITNO (IMOD POSITION BITSPERWORD))
W1 HIBITNO)
(SETQ ADDR (\ADDBASE ADDR WORDNO))
(SETQ W1 (\GETBASE ADDR 0))
(SETQ HIBITNO (IPLUS SIZE LOBITNO -1))
(RETURN (COND
((ILESSP HIBITNO BITSPERWORD)
(\XLOADBYTEWORD W1 LOBITNO SIZE))
(T (PROG ((NBITS.W1 (IDIFFERENCE BITSPERWORD LOBITNO))
(W2 (\GETBASE ADDR 1))
(LOBYTE (IMIN SIZE BITSPERWORD)))
(SETQ LOBYTE (\XDEPOSITBYTEWORD (\XLRSHWORD W1 LOBITNO)
NBITS.W1
(IDIFFERENCE LOBYTE NBITS.W1)
W2))
(RETURN (COND
((ILESSP HIBITNO (CONSTANT (TIMES 2 BITSPERWORD)))
(* Byte comes from at most two words)
(COND
((ILEQ SIZE BITSPERWORD)
(* Byte is not larger than one word, and is taken from
parts of only two words.)
LOBYTE)
(T (\MAKENUMBER (\XLRSHWORD W2 (IDIFFERENCE SIZE
BITSPERWORD))
LOBYTE))))
(T (* Sigh, from parts of three words.)
(\MAKENUMBER (\XDEPOSITBYTEWORD
(\XLRSHWORD W2 LOBITNO)
NBITS.W1
(IDIFFERENCE HIBITNO
(CONSTANT (SUB1 (TIMES 2
BITSPERWORD))))
(\GETBASE ADDR 2))
LOBYTE)))))))))))
(\PUTBASEINTEGER
(LAMBDA (ADDR POSITION SIZE VAL) (* JonL "14-OCT-82 10:31")
(PROG ((WORDNO (FOLDLO POSITION BITSPERWORD))
(LOBITNO (IMOD POSITION BITSPERWORD))
W1 HIBITNO)
(SETQ ADDR (\ADDBASE ADDR WORDNO))
(SETQ W1 (\GETBASE ADDR 0))
(SETQ HIBITNO (IPLUS SIZE LOBITNO -1))
(COND
((ILESSP HIBITNO BITSPERWORD)
(\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD W1 LOBITNO SIZE (OR (SMALLP VAL)
(\LONUM VAL)))))
(T (PROG ((NBITS.W1 (IDIFFERENCE BITSPERWORD LOBITNO))
(W2 (\GETBASE ADDR 1))
NW2 VHI VLO)
(.XUNBOX. VAL VHI VLO)
(\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD W1 LOBITNO NBITS.W1 VLO))
(COND
((ILESSP HIBITNO (CONSTANT (TIMES 2 BITSPERWORD)))
(* Spread over just two words)
(SETQ NW2 (IDIFFERENCE SIZE NBITS.W1))
(* NW2 here holds the number of right-justified bits put
into the second word)
(SETQ VLO (\XLRSHWORD VLO NBITS.W1))
(COND
((IGREATERP SIZE BITSPERWORD)
(SETQ VLO (\XDEPOSITBYTEWORD VLO (IDIFFERENCE BITSPERWORD NBITS.W1)
(IDIFFERENCE SIZE NBITS.W1)
VHI))))
(\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD W2 0 NW2 VLO)))
(T (* Sigh, into parts of three words.)
(\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD (\XLRSHWORD VLO NBITS.W1)
(IDIFFERENCE BITSPERWORD NBITS.W1)
NBITS.W1 VHI))
(\PUTBASE ADDR 2 (\XDEPOSITBYTEWORD (\GETBASE ADDR 2)
0
(IDIFFERENCE
HIBITNO
(CONSTANT (SUB1 (TIMES 2 BITSPERWORD))
))
(\XLRSHWORD VHI NBITS.W1)))))))))
VAL))
)
(* Primitive functions, especially needed for CommonLisp array package.)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETBASEFLOATP DMACRO ((BASE OFFST)
((LAMBDA (\NewBaseAddr)
(DECLARE (LOCALVARS \NewBaseAddr))
(create FLOATP
HIWORD ←(\GETBASE \NewBaseAddr 0)
LOWORD ←(\GETBASE \NewBaseAddr 1)))
(\ADDBASE BASE OFFST))))
(PUTPROPS \PUTBASEFLOATP DMACRO ((BASE OFFST VAL)
((LAMBDA (\NewBaseAddr \NewVal)
(DECLARE (LOCALVARS \NewBaseAddr \NewVal))
(OR (FLOATP \NewVal)
(\ILLEGAL.ARG \NewVal))
(\PUTBASE \NewBaseAddr 0 (fetch (FLOATP HIWORD) of \NewVal))
(\PUTBASE \NewBaseAddr 1 (fetch (FLOATP LOWORD) of \NewVal))
\NewVal)
(\ADDBASE BASE OFFST)
VAL)))
(PUTPROPS \GETBASEFIXP DMACRO ((BASE D)
((LAMBDA (\NewBaseAddr)
(\MAKENUMBER (\GETBASE \NewBaseAddr 0)
(\GETBASE \NewBaseAddr 1)))
(\ADDBASE BASE D))))
(PUTPROPS \PUTBASEFIXP DMACRO ((BASE OFFST VAL)
(* JonL "14-OCT-82 11:24")
((LAMBDA (\NewBaseAddr \NewVal \HiPart \LoPart)
(DECLARE (LOCALVARS \NewBaseAddr \NewVal \HiPart \LoPart))
(.XUNBOX. \NewVal \HiPart \LoPart)
(\PUTBASE \NewBaseAddr 0 \HiPart)
(\PUTBASE \NewBaseAddr 1 \LoPart)
\NewVal)
(\ADDBASE BASE OFFST)
VAL)))
(PUTPROPS \GETBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST)
((LAMBDA (\Byte)
(DECLARE (LOCALVARS \Byte))
(if (ODDP OFFST)
then (LOGAND \Byte (CONSTANT (MASK.1'S 0 BITSPERNIBBLE)))
else (LRSH \Byte BITSPERNIBBLE)))
(\GETBASEBYTE BASE (FOLDLO OFFST NIBBLESPERBYTE)))))
(PUTPROPS \PUTBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST VAL)
((LAMBDA (\ByteNo)
(DECLARE (LOCALVARS \ByteNo))
((LAMBDA (\Byte)
(DECLARE (LOCALVARS \Byte))
(\PUTBASEBYTE BASE \ByteNo (if (ODDP OFFST)
then (LOGOR (LOGAND \Byte (CONSTANT (MASK.1'S BITSPERNIBBLE
BITSPERNIBBLE)))
VAL)
else (LOGOR (LOGAND \Byte (CONSTANT (MASK.1'S 0 BITSPERNIBBLE))
)
(LLSH VAL BITSPERNIBBLE)))))
(\GETBASEBYTE BASE \ByteNo)))
(FOLDLO OFFST NIBBLESPERBYTE))))
(PUTPROPS \GETBASEBIT DMACRO (OPENLAMBDA (BASE OFFST)
((LAMBDA (\ByteNo \BitMask)
(DECLARE (LOCALVARS \ByteNo \BitMask))
(if (ZEROP (LOGAND \BitMask (\GETBASEBYTE BASE \ByteNo)))
then 0
else 1))
(FOLDLO OFFST BITSPERBYTE)
(MASK.1'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE))
(IMOD OFFST BITSPERBYTE))
1))))
(PUTPROPS \PUTBASEBIT DMACRO (OPENLAMBDA (BASE OFFST VAL)
((LAMBDA (\ByteNo \BitMask \Byte)
(DECLARE (LOCALVARS \ByteNo \BitMask \Byte))
(SETQ \Byte (\GETBASEBYTE BASE \ByteNo))
(if (if (ZEROP (LOGAND \BitMask \Byte))
then (NOT (ZEROP VAL))
else (ZEROP VAL))
then (\PUTBASEBYTE BASE \ByteNo (LOGXOR \BitMask \Byte)))
VAL)
(FOLDLO OFFST BITSPERBYTE)
(MASK.1'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE))
(IMOD OFFST BITSPERBYTE))
1))))
)
)
(* END EXPORTED DEFINITIONS)
(DEFINEQ
(\GETBASEFLOATP
(LAMBDA (BASE OFFST) (* JonL " 7-FEB-83 19:41")
(\MACRO.MX (\GETBASEFLOATP BASE OFFST))))
(\PUTBASEFLOATP
(LAMBDA (BASE OFFST VAL) (* JonL " 7-FEB-83 19:42")
(\MACRO.MX (\PUTBASEFLOATP BASE OFFST VAL))))
(\GETBASEFIXP
(LAMBDA (BASE OFFST) (* JonL "19-OCT-82 20:50")
(\MACRO.MX (\GETBASEFIXP BASE OFFST))))
(\PUTBASEFIXP
(LAMBDA (BASE OFFST VAL) (* JonL " 7-FEB-83 20:57")
(\MACRO.MX (\PUTBASEFIXP BASE OFFST VAL))))
(\GETBASENIBBLE
(LAMBDA (BASE OFFST) (* JonL "16-FEB-83 19:45")
(\MACRO.MX (\GETBASENIBBLE BASE OFFST))))
(\PUTBASENIBBLE
(LAMBDA (BASE OFFST VAL) (* JonL "16-FEB-83 19:52")
(\MACRO.MX (\PUTBASENIBBLE BASE OFFST VAL))))
(\GETBASEBIT
(LAMBDA (BASE OFFST) (* JonL "27-JAN-83 20:34")
(\MACRO.MX (\GETBASEBIT BASE OFFST))))
(\PUTBASEBIT
(LAMBDA (BASE OFFST VAL) (* JonL " 7-FEB-83 21:01")
(\MACRO.MX (\PUTBASEBIT BASE OFFST VAL))))
)
(* Beginning of rewrite of some LLARITH things, modularly using the macros of this file)
(DEFINEQ
(NEWTRUNCATEMULTIPLY
(LAMBDA (X Y) (* JonL "28-OCT-82 22:14")
(* 32-bit, unsigned, multiply.
Return lower 32 bits)
(* Must ignore the \OVERFLOW flg -- can be called by
bignum routines wherein the setting of this flg is
random)
(PROG ((HR 0)
(LR 0))
(.32BITMUL. HR LR X Y)
(RETURN (\MAKENUMBER HR LR)))))
)
(PUTPROPS ADDARITH COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3903 4656 (\VectorLENGTH 3913 . 4102) (\MakeVector 4104 . 4250) (\VectorREF 4252 . 4450
) (\VectorSET 4452 . 4654)) (4688 6057 (\SETUP.MASKARRAYS 4698 . 6055)) (7072 7837 (\MASK.1'S.EXPANDER
7082 . 7835)) (7838 9229 (MASK.1'S 7848 . 8312) (MASK.0'S 8314 . 8667) (BITTEST 8669 . 8812) (BITSET
8814 . 8955) (BITCLEAR 8957 . 9102) (LOGNOT 9104 . 9227)) (9346 10111 (\MASK.1'S.EXPANDER 9356 . 10109
)) (11451 12467 (LOADBYTE 11461 . 11809) (DEPOSITBYTE 11811 . 12465)) (13338 22254 (\LDBEXPANDER 13348
. 15175) (\DPBEXPANDER 15177 . 17846) (\LOADBYTEEXPANDER 17848 . 19328) (\DEPOSITBYTEEXPANDER 19330
. 22252)) (22371 26787 (\LOADBYTEEXPANDER 22381 . 23861) (\DEPOSITBYTEEXPANDER 23863 . 26785)) (32795
36097 (IMODLESSP 32805 . 34352) (IMODPLUS 34354 . 35211) (IMODDIFFERENCE 35213 . 36095)) (36920 38168
(ROT 36930 . 38166)) (38245 39529 (\ROTexpander 38255 . 39527)) (39848 44600 (\XLOADBYTE 39858 .
40419) (\XLOADBYTEWORD 40421 . 40683) (\XDEPOSITBYTE 40685 . 41625) (\XDEPOSITBYTEWORD 41627 . 42425)
(\XLLSHWORD 42427 . 43494) (\XLRSHWORD 43496 . 44598)) (44601 54048 (\GETBASEBITS 44611 . 47630) (
\PUTBASEBITS 47632 . 50574) (\GETBASEINTEGER 50576 . 52177) (\PUTBASEINTEGER 52179 . 54046)) (57286
58596 (\GETBASEFLOATP 57296 . 57457) (\PUTBASEFLOATP 57459 . 57624) (\GETBASEFIXP 57626 . 57783) (
\PUTBASEFIXP 57785 . 57946) (\GETBASENIBBLE 57948 . 58109) (\PUTBASENIBBLE 58111 . 58276) (\GETBASEBIT
58278 . 58433) (\PUTBASEBIT 58435 . 58594)) (58694 59272 (NEWTRUNCATEMULTIPLY 58704 . 59270)))))
STOP