(FILECREATED " 7-May-84 01:20:31" {PHYLUM}<LISPCORE>SOURCES>ADDARITH.;3 61333
changes to: (VARS ADDARITHCOMS)
(FNS IMODLESSP)
previous date: "24-Apr-84 12:51:39" {PHYLUM}<LISPCORE>SOURCES>ADDARITH.;2)
(* Copyright (c) 1982, 1983, 1984 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))))
(COMS (* Some version of the following should be done in MACHINEDEPENDENT for
the other Interlisps.)
(GLOBALRESOURCES \MODLESSPBOX)
(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.)
(DECLARE: DONTCOPY (MACROS .HIHALFWORDLO. .HIHALFWORDHI. .LOHALFWORDLO.
.LOHALFWORDHI.)
(EXPORT (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)
(DECLARE: DONTCOPY (EXPORT (CONSTANTS MASK0WORD1'S MASK1WORD0'S
MASKWORD1'S MASKHALFWORD1'S
BITSPERHALFWORD)
(MACROS EQZEROP)
(MACROS \MOVETOBOX .XUNBOX. .XLLSH. .XLLSH1.
.XLRSH. .ADD.2WORD.INTEGERS.
.SUB.2WORD.INTEGERS. .32BITMUL.)
(MACROS .SUMSMALLMOD. .DIFFERENCESMALLMOD.))
(MACROS .ADD.2WORD.INTEGERS. .SUB.2WORD.INTEGERS. .32BITMUL.))
(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 "24-Apr-84 12:47")
(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 (EQZEROP 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 "24-Apr-84 12:47")
(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 (EQZEROP 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 "24-Apr-84 12:51")
((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 (EQZEROP 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 (EQZEROP POS)
then WORD
else (LIST (QUOTE LRSH)
WORD POS))
MASK)))))))))
(\DEPOSITBYTEEXPANDER
(LAMBDA (X) (* JonL "24-Apr-84 12:51")
((LAMBDA (POS SIZE)
(if (AND SIZE (ILEQ SIZE 0))
then (if (EQZEROP 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 (EQZEROP (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 (EQZEROP (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 (EQZEROP 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 "24-Apr-84 12:51")
((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 (EQZEROP 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 (EQZEROP POS)
then WORD
else (LIST (QUOTE LRSH)
WORD POS))
MASK)))))))))
(\DEPOSITBYTEEXPANDER
(LAMBDA (X) (* JonL "24-Apr-84 12:51")
((LAMBDA (POS SIZE)
(if (AND SIZE (ILEQ SIZE 0))
then (if (EQZEROP 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 (EQZEROP (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 (EQZEROP (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 (EQZEROP 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)))))
)
)
(* Some version of the following should be done in MACHINEDEPENDENT for the other Interlisps.)
(RPAQQ \\MODLESSPBOX.GLOBALRESOURCE NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \MODLESSPBOX)
(QUOTE GLOBALRESOURCES)
(QUOTE (NEW (NCREATE (QUOTE FIXP)))))
)
(DEFINEQ
(IMODLESSP
(LAMBDA (X Y MODULUS EQUAL?) (* JonL " 7-May-84 01:20")
(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 (EQZEROP X)
then EQUAL?
else (ILESSP X (CONSTANT (EXPT 2 (SUB1 BITSPERWORD)))))
elseif (OR (EQ MODULUS (QUOTE CELL))
(AND (FIXP MODULUS)
(POWEROFTWOP MODULUS)))
then (GLOBALRESOURCE (\MODLESSPBOX)
(\MOVETOBOX Y \MODLESSPBOX)
(\BOXIDIFFERENCE \MODLESSPBOX X)
(if (AND (EQZEROP (fetch (FIXP HINUM) of \MODLESSPBOX))
(EQZEROP (fetch (FIXP LONUM) of \MODLESSPBOX)))
then EQUAL?
elseif (EQ MODULUS (QUOTE CELL))
then (IGREATERP \MODLESSPBOX 0)
elseif (SMALLP MODULUS)
then (if (EQZEROP (SETQ X (LOGAND \MODLESSPBOX (SUB1 MODULUS))))
then EQUAL?
else (ILESSP X (LRSH MODULUS 1)))
else (PROG ((DIV (SUB1 (INTEGERLENGTH MODULUS))))
(RETURN (if (EQZEROP (SETQ X (LOGAND \MODLESSPBOX
(MASK.1'S 0 DIV))))
then EQUAL?
else (ILESSP X (MASK.1'S (SUB1 DIV)
1)))))))
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.)
(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 \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 (EQ 0 (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 (EQ 0 (LOGAND \BitMask \Byte))
then (NOT (EQ 0 VAL))
else (EQ 0 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)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(RPAQQ MASK0WORD1'S 32767)
(RPAQQ MASK1WORD0'S 32768)
(RPAQQ MASKWORD1'S 65535)
(RPAQQ MASKHALFWORD1'S 255)
(RPAQQ BITSPERHALFWORD 8)
(CONSTANTS MASK0WORD1'S MASK1WORD0'S MASKWORD1'S MASKHALFWORD1'S BITSPERHALFWORD)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS EQZEROP MACRO ((X) (EQ X 0)))
)
(DECLARE: EVAL@COMPILE
(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 .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 .XLLSH. MACRO ((HI LO N)
(if (IGEQ N BITSPERWORD)
then (* Jump 16 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 .XLLSH1. MACRO ((HI LO)
(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 .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 .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))))
)
(DECLARE: EVAL@COMPILE
(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))))))
)
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE
(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))))
)
)
(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 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4067 4820 (\VectorLENGTH 4077 . 4266) (\MakeVector 4268 . 4414) (\VectorREF 4416 . 4614
) (\VectorSET 4616 . 4818)) (4852 6221 (\SETUP.MASKARRAYS 4862 . 6219)) (7236 8011 (\MASK.1'S.EXPANDER
7246 . 8009)) (8012 9403 (MASK.1'S 8022 . 8486) (MASK.0'S 8488 . 8841) (BITTEST 8843 . 8986) (BITSET
8988 . 9129) (BITCLEAR 9131 . 9276) (LOGNOT 9278 . 9401)) (9520 10295 (\MASK.1'S.EXPANDER 9530 . 10293
)) (11631 12647 (LOADBYTE 11641 . 11989) (DEPOSITBYTE 11991 . 12645)) (13518 22446 (\LDBEXPANDER 13528
. 15355) (\DPBEXPANDER 15357 . 18026) (\LOADBYTEEXPANDER 18028 . 19512) (\DEPOSITBYTEEXPANDER 19514
. 22444)) (22563 26991 (\LOADBYTEEXPANDER 22573 . 24057) (\DEPOSITBYTEEXPANDER 24059 . 26989)) (27273
30681 (IMODLESSP 27283 . 28936) (IMODPLUS 28938 . 29795) (IMODDIFFERENCE 29797 . 30679)) (31504 32752
(ROT 31514 . 32750)) (32829 34113 (\ROTexpander 32839 . 34111)) (34432 39184 (\XLOADBYTE 34442 .
35003) (\XLOADBYTEWORD 35005 . 35267) (\XDEPOSITBYTE 35269 . 36209) (\XDEPOSITBYTEWORD 36211 . 37009)
(\XLLSHWORD 37011 . 38078) (\XLRSHWORD 38080 . 39182)) (39185 48632 (\GETBASEBITS 39195 . 42214) (
\PUTBASEBITS 42216 . 45158) (\GETBASEINTEGER 45160 . 46761) (\PUTBASEINTEGER 46763 . 48630)) (52240
53550 (\GETBASEFLOATP 52250 . 52411) (\PUTBASEFLOATP 52413 . 52578) (\GETBASEFIXP 52580 . 52737) (
\PUTBASEFIXP 52739 . 52900) (\GETBASENIBBLE 52902 . 53063) (\PUTBASENIBBLE 53065 . 53230) (\GETBASEBIT
53232 . 53387) (\PUTBASEBIT 53389 . 53548)) (60666 61244 (NEWTRUNCATEMULTIPLY 60676 . 61242)))))
STOP