(FILECREATED "10-Jan-85 15:51:00" {ERIS}<LISPCORE>SOURCES>ADDARITH.;9 67307
changes to: (FNS \RTIMES2 CREATERATIONAL)
previous date: " 6-Jan-85 01:09:17" {ERIS}<LISPCORE>SOURCES>ADDARITH.;8)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ADDARITHCOMS)
(RPAQQ ADDARITHCOMS ((DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (P (SETQ CLISPIFTRANFLG T)))
(LOCALVARS . T)
(COMS (* Rational operations and useful constants)
(FNS \RTIMES2 \RPLUS2 \RMINUS CREATERATIONAL RATIONALTOINTEGER)
(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 \VectorLENGTH \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 \GETBASENIBBLE \PUTBASENIBBLE \GETBASEBIT
\PUTBASEBIT)))
(FNS \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)
)
(* Rational operations and useful constants)
(DEFINEQ
(\RTIMES2
[LAMBDA (R1 R2) (* jds "10-Jan-85 15:36")
(* Rational multiply)
(COND
[(FIXP R1)
(COND
((FIXP R2)
(ITIMES R1 R2))
(T [COND
((FLOATP R2)
(SETQ R2 (MAKERATIONAL R2]
(COND
((IEQP R1 (fetch DENOMINATOR of R2))
(fetch NUMERATOR of R2))
(T (create RATIONAL
NUMERATOR ←(ITIMES R1 (fetch NUMERATOR of R2))
DENOMINATOR ←(fetch DENOMINATOR of R2]
(T [COND
((FLOATP R1)
(SETQ R1 (MAKERATIONAL R1]
(COND
[(FIXP R2)
(COND
((IEQP R2 (fetch DENOMINATOR of R1))
(fetch NUMERATOR of R1))
(T (create RATIONAL
NUMERATOR ←(TIMES R2 (fetch NUMERATOR of R1))
DENOMINATOR ←(fetch DENOMINATOR of R1]
((IEQP (fetch NUMERATOR of R1)
(fetch DENOMINATOR of R2))
(create RATIONAL
NUMERATOR ←(fetch NUMERATOR of R2)
DENOMINATOR ←(fetch DENOMINATOR of R1)))
((IEQP (fetch DENOMINATOR of R1)
(fetch NUMERATOR of R2))
(create RATIONAL
NUMERATOR ←(fetch NUMERATOR of R1)
DENOMINATOR ←(fetch DENOMINATOR of R2)))
(T (create RATIONAL
NUMERATOR ←(ITIMES (fetch NUMERATOR of R1)
(fetch NUMERATOR of R2))
DENOMINATOR ←(ITIMES (fetch DENOMINATOR of R1)
(fetch DENOMINATOR of R2])
(\RPLUS2
(LAMBDA (R1 R2) (* rmk: "21-JUL-82 17:57")
(* Rational multiply)
(COND
((FIXP R1)
(COND
((FIXP R2)
(IPLUS R1 R2))
(T (COND
((FLOATP R2)
(SETQ R2 (MAKERATIONAL R2))))
(create RATIONAL
NUMERATOR ←(IPLUS (fetch NUMERATOR of R2)
(ITIMES R1 (fetch DENOMINATOR of R2)))
DENOMINATOR ←(fetch DENOMINATOR of R2)))))
(T (COND
((FLOATP R1)
(SETQ R1 (MAKERATIONAL R1))))
(COND
((FIXP R2)
(create RATIONAL
NUMERATOR ←(IPLUS (fetch NUMERATOR of R1)
(ITIMES R2 (fetch DENOMINATOR of R1)))
DENOMINATOR ←(fetch DENOMINATOR of R1)))
((IEQP (fetch DENOMINATOR of R1)
(fetch DENOMINATOR of R2))
(create RATIONAL
NUMERATOR ←(IPLUS (fetch NUMERATOR of R1)
(fetch NUMERATOR of R2))
DENOMINATOR ←(fetch DENOMINATOR of R2)))
(T (create RATIONAL
NUMERATOR ←(IPLUS (ITIMES (fetch DENOMINATOR of R1)
(fetch NUMERATOR of R2))
(ITIMES (fetch NUMERATOR of R1)
(fetch DENOMINATOR of R2)))
DENOMINATOR ←(ITIMES (fetch DENOMINATOR of R1)
(fetch DENOMINATOR of R2)))))))))
(\RMINUS
(LAMBDA (X) (* JonL " 4-Jan-85 16:08")
(if (type? RATIONAL X)
then (create RATIONAL
NUMERATOR ←(MINUS (fetch (RATIONAL NUMERATOR) of X))
DENOMINATOR ←(fetch (RATIONAL NUMERATOR) of X))
else (MINUS X))))
(CREATERATIONAL
[LAMBDA (NUMERATOR DENOMINATOR) (* jds "10-Jan-85 15:40")
(* Creates a normalized rational)
(PROG ((PNUM NUMERATOR)
(PDEN DENOMINATOR)
GCF NEGFLG)
(* * Convert to positive format first, since this will minimize consing in GCD and keep the IQUOTIENT in ucode
(where possible))
(if (ILESSP PNUM 0)
then (SETQ PNUM (IMINUS PNUM))
(if (ILESSP PDEN 0)
then (SETQ PDEN (IMINUS PDEN))
else (SETQ NEGFLG T))
else (if (ILESSP PDEN 0)
then (SETQ PDEN (IMINUS PDEN))
(SETQ NEGFLG T)))
(SETQ GCF (GCD PNUM PDEN)) (* Note that the GCD will always be positive)
(SETQ PNUM (IQUOTIENT PNUM GCF)) (* Reduce both numerator and denominator by the GCD)
(SETQ PDEN (IQUOTIENT PDEN GCF))
(RETURN (CONS (if NEGFLG
then (IMINUS PNUM)
else PNUM)
PDEN])
(RATIONALTOINTEGER
(LAMBDA (RAT) (* JonL " 4-Jan-85 15:59")
(FIXR (FQUOTIENT (fetch (RATIONAL NUMERATOR) of RAT)
(fetch (RATIONAL DENOMINATOR) of RAT)))))
)
[DECLARE: EVAL@COMPILE
(RECORD RATIONAL (NUMERATOR . DENOMINATOR)
[TYPE? (AND (LISTP DATUM)
(FIXP (CAR DATUM))
(FIXP (CDR DATUM]
(CREATE (CREATERATIONAL NUMERATOR DENOMINATOR)))
]
(* "These facilities should be common with Interlisp-10 and Interlisp-VAX")
(* "Vectors are fast equivalents to 0-origin POINTER arrays")
(DECLARE: EVAL@COMPILE
(PUTPROPS \VectorLENGTH MACRO (= . \#BLOCKDATACELLS))
(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 " 4-Jan-85 16:45")
(\MACRO.MX (\VectorLENGTH X))))
(\MakeVector
(LAMBDA (N) (* JonL "20-OCT-83 10:52")
(\MACRO.MX (\MakeVector N))))
(\VectorREF
(LAMBDA (X I) (* JonL " 4-Jan-85 16:41")
(OR (\BLOCKDATAP X)
(\ILLEGAL.ARG X))
(\MACRO.MX (\VectorREF X I))))
(\VectorSET
(LAMBDA (X I VAL) (* JonL " 4-Jan-85 16:41")
(OR (\BLOCKDATAP 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 "27-Sep-84 23:28")
(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 (EQ 0 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
(DEFINEQ
(\MASK.1'S.EXPANDER
(LAMBDA (X) (* JonL "27-Sep-84 23:28")
(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 (EQ 0 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 "27-Sep-84 23:29")
((LAMBDA (SIZE)
(SETQ SIZE (EVALUABLE.CONSTANT.FIXP (CADDR X)))
(if (NULL SIZE)
then ((LAMBDA (POS)
(if POS
then (LIST (QUOTE LOGAND)
(LIST (QUOTE LRSH)
(CAR X)
POS)
(LIST (QUOTE 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 (EQ 0 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 (EQ 0 POS)
then WORD
else (LIST (QUOTE LRSH)
WORD POS))
MASK)))))))))
(\DEPOSITBYTEEXPANDER
(LAMBDA (X) (* JonL "27-Sep-84 23:30")
((LAMBDA (POS SIZE)
(if (AND SIZE (ILEQ SIZE 0))
then (if (EQ 0 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 (EQ 0 (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 (EQ 0 (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 (LIST (QUOTE LOGAND)
VAL MASK))
(if (NOT (EQ 0 POS))
then (SETQ VAL (LIST (QUOTE LLSH)
VAL POS))))
(LIST (QUOTE LOGOR)
MWORD VAL)))
(LIST (QUOTE BITCLEAR)
WORD
(LLSH MASK POS))))))))
(EVALUABLE.CONSTANT.FIXP (CADR X))
(EVALUABLE.CONSTANT.FIXP (CADDR X)))))
)
(DECLARE: DONTCOPY EVAL@COMPILE
(DEFINEQ
(\LOADBYTEEXPANDER
(LAMBDA (X) (* JonL "27-Sep-84 23:29")
((LAMBDA (SIZE)
(SETQ SIZE (EVALUABLE.CONSTANT.FIXP (CADDR X)))
(if (NULL SIZE)
then ((LAMBDA (POS)
(if POS
then (LIST (QUOTE LOGAND)
(LIST (QUOTE LRSH)
(CAR X)
POS)
(LIST (QUOTE 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 (EQ 0 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 (EQ 0 POS)
then WORD
else (LIST (QUOTE LRSH)
WORD POS))
MASK)))))))))
(\DEPOSITBYTEEXPANDER
(LAMBDA (X) (* JonL "27-Sep-84 23:30")
((LAMBDA (POS SIZE)
(if (AND SIZE (ILEQ SIZE 0))
then (if (EQ 0 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 (EQ 0 (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 (EQ 0 (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 (LIST (QUOTE LOGAND)
VAL MASK))
(if (NOT (EQ 0 POS))
then (SETQ VAL (LIST (QUOTE LLSH)
VAL POS))))
(LIST (QUOTE LOGOR)
MWORD VAL)))
(LIST (QUOTE 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.")
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \MODLESSPBOX)
(QUOTE RESOURCES)
(QUOTE (NEW (NCREATE (QUOTE FIXP]
)
)
(/SETTOPVAL (QUOTE \\MODLESSPBOX.GLOBALRESOURCE))
(DEFINEQ
(IMODLESSP
(LAMBDA (X Y MODULUS EQUAL?) (* JonL "27-Sep-84 23:31")
(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 (EQ 0 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 (EQ 0 (fetch (FIXP HINUM) of \MODLESSPBOX))
(EQ 0 (fetch (FIXP LONUM) of \MODLESSPBOX)))
then EQUAL?
elseif (EQ MODULUS (QUOTE CELL))
then (IGREATERP \MODLESSPBOX 0)
elseif (SMALLP MODULUS)
then (if (EQ 0 (SETQ X (LOGAND \MODLESSPBOX (SUB1 MODULUS))))
then EQUAL?
else (ILESSP X (LRSH MODULUS 1)))
else (PROG ((DIV (SUB1 (INTEGERLENGTH MODULUS))))
(RETURN (if (EQ 0 (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 \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
(\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 0 X)))
)
(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
((IGEQ X 0)
(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 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3551 8501 (\RTIMES2 3561 . 5223) (\RPLUS2 5225 . 6742) (\RMINUS 6744 . 7081) (
CREATERATIONAL 7083 . 8253) (RATIONALTOINTEGER 8255 . 8499)) (9232 9970 (\VectorLENGTH 9242 . 9398) (
\MakeVector 9400 . 9546) (\VectorREF 9548 . 9755) (\VectorSET 9757 . 9968)) (10004 11373 (
\SETUP.MASKARRAYS 10014 . 11371)) (12487 13347 (\MASK.1'S.EXPANDER 12497 . 13345)) (13348 14739 (
MASK.1'S 13358 . 13822) (MASK.0'S 13824 . 14177) (BITTEST 14179 . 14322) (BITSET 14324 . 14465) (
BITCLEAR 14467 . 14612) (LOGNOT 14614 . 14737)) (14773 15633 (\MASK.1'S.EXPANDER 14783 . 15631)) (
17131 18147 (LOADBYTE 17141 . 17489) (DEPOSITBYTE 17491 . 18145)) (19106 28605 (\LDBEXPANDER 19116 .
20943) (\DPBEXPANDER 20945 . 23614) (\LOADBYTEEXPANDER 23616 . 25329) (\DEPOSITBYTEEXPANDER 25331 .
28603)) (28639 33638 (\LOADBYTEEXPANDER 28649 . 30362) (\DEPOSITBYTEEXPANDER 30364 . 33636)) (33935
37557 (IMODLESSP 33945 . 35812) (IMODPLUS 35814 . 36671) (IMODDIFFERENCE 36673 . 37555)) (38444 39692
(ROT 38454 . 39690)) (39767 41051 (\ROTexpander 39777 . 41049)) (41313 46065 (\XLOADBYTE 41323 . 41884
) (\XLOADBYTEWORD 41886 . 42148) (\XDEPOSITBYTE 42150 . 43090) (\XDEPOSITBYTEWORD 43092 . 43890) (
\XLLSHWORD 43892 . 44959) (\XLRSHWORD 44961 . 46063)) (46066 55513 (\GETBASEBITS 46076 . 49095) (
\PUTBASEBITS 49097 . 52039) (\GETBASEINTEGER 52041 . 53642) (\PUTBASEINTEGER 53644 . 55511)) (58116
58774 (\GETBASENIBBLE 58126 . 58287) (\PUTBASENIBBLE 58289 . 58454) (\GETBASEBIT 58456 . 58611) (
\PUTBASEBIT 58613 . 58772)) (66635 67213 (NEWTRUNCATEMULTIPLY 66645 . 67211)))))
STOP