(FILECREATED "24-Sep-86 18:52:54" {ERIS}<LISPCORE>SOURCES>ADDARITH.;22 40340
changes to: (VARS ADDARITHCOMS)
(FNS \RTIMES2 \RPLUS2 \RMINUS)
previous date: "14-Aug-86 14:28:11" {ERIS}<LISPCORE>SOURCES>ADDARITH.;19)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ADDARITHCOMS)
(RPAQQ ADDARITHCOMS ((LOCALVARS . T)
(COMS (* Rational operations and useful constants)
(FNS \RTIMES2 \RATIONALIZE \RPLUS2 \RMINUS CREATERATIONAL
RATIONALTOINTEGER)
(RECORDS RATIONAL))
(* OK)
(MACROS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR)
(OPTIMIZERS LOGNOT)
(FNS LOGNOT)
(* "BYTE hacking functions")
(RECORDS BYTESPEC)
(FNS LOADBYTE DEPOSITBYTE)
(OPTIMIZERS LOADBYTE DEPOSITBYTE)
(FNS IMODLESSP IMODPLUS IMODDIFFERENCE)
(OPTIMIZERS IMOD IMODPLUS IMODDIFFERENCE)
(FNS ROT)
(MACROS .ROT.)
(* NOT OK YET)
(OPTIMIZERS BYTE DPB LDB)
(MACROS BYTESIZE BYTEPOSITION)
(FNS LDB DPB BYTE)
(FNS \LDBEXPANDER \DPBEXPANDER)
(COMS (* "Primitive Functions for extracting fields as integers")
(MACROS \XLOADBYTEWORD)
(FNS \PUTBASEBITS)
(* "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.)))
(PROP FILETYPE ADDARITH DF CREATERATIONAL)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(* Rational operations and useful constants)
(DEFINEQ
(\RTIMES2
(LAMBDA (R1 R2) (* Pavel "24-Sep-86 18:48")
(* ; "Rational multiply")
(if (FLOATP R1)
then (SETQ R1 (MAKERATIONAL R1)))
(if (FLOATP R2)
then (SETQ R2 (MAKERATIONAL R2)))
(if (FIXP R1)
then (if (FIXP R2)
then (ITIMES R1 R2)
else (if (EQUAL R1 (fetch (RATIONAL DENOMINATOR) of R2))
then (fetch (RATIONAL NUMERATOR) of R2)
else (\RATIONALIZE (ITIMES R1 (fetch (RATIONAL NUMERATOR) of R2))
(fetch (RATIONAL DENOMINATOR) of R2))))
elseif (FIXP R2)
then (if (EQUAL R2 (fetch (RATIONAL DENOMINATOR) of R1))
then (fetch (RATIONAL NUMERATOR) of R1)
else (\RATIONALIZE (TIMES R2 (fetch (RATIONAL NUMERATOR) of R1))
(fetch (RATIONAL DENOMINATOR) of R1)))
elseif (EQUAL (fetch (RATIONAL NUMERATOR) of R1)
(fetch (RATIONAL DENOMINATOR) of R2))
then (\RATIONALIZE (fetch (RATIONAL NUMERATOR) of R2)
(fetch (RATIONAL DENOMINATOR) of R1))
elseif (EQUAL (fetch (RATIONAL DENOMINATOR) of R1)
(fetch (RATIONAL NUMERATOR) of R2))
then (\RATIONALIZE (fetch (RATIONAL NUMERATOR) of R1)
(fetch (RATIONAL DENOMINATOR) of R2))
else (\RATIONALIZE (ITIMES (fetch (RATIONAL NUMERATOR) of R1)
(fetch (RATIONAL NUMERATOR) of R2))
(ITIMES (fetch (RATIONAL DENOMINATOR) of R1)
(fetch (RATIONAL DENOMINATOR) of R2))))))
(\RATIONALIZE
[LAMBDA (NUM DEN) (* lmm "14-Apr-85 20:19")
(LET ((GCD (GCD NUM DEN)))
(if (EQUAL DEN GCD)
then (IQUOTIENT NUM GCD)
else (create RATIONAL
NUMERATOR ←(IQUOTIENT NUM GCD)
DENOMINATOR ←(IQUOTIENT DEN GCD])
(\RPLUS2
(LAMBDA (R1 R2) (* Pavel "24-Sep-86 18:50")
(* ; "Rational multiply")
(IF (FLOATP R1)
THEN (SETQ R1 (MAKERATIONAL R1)))
(IF (FLOATP R2)
THEN (SETQ R2 (MAKERATIONAL R2)))
(if (FIXP R1)
then (if (FIXP R2)
then (IPLUS R1 R2)
else (\RATIONALIZE (IPLUS (fetch (RATIONAL NUMERATOR) of R2)
(ITIMES R1 (fetch (RATIONAL DENOMINATOR) of R2)))
(fetch (RATIONAL DENOMINATOR) of R2)))
elseif (FIXP R2)
then (\RATIONALIZE (IPLUS (fetch (RATIONAL NUMERATOR) of R1)
(ITIMES R2 (fetch (RATIONAL DENOMINATOR) of R1)))
(fetch (RATIONAL DENOMINATOR) of R1))
elseif (EQUAL (fetch (RATIONAL DENOMINATOR) of R1)
(fetch (RATIONAL DENOMINATOR) of R2))
then (\RATIONALIZE (IPLUS (fetch (RATIONAL NUMERATOR) of R1)
(fetch (RATIONAL NUMERATOR) of R2))
(fetch (RATIONAL DENOMINATOR) of R2))
else (\RATIONALIZE (IPLUS (ITIMES (fetch (RATIONAL DENOMINATOR) of R1)
(fetch (RATIONAL NUMERATOR) of R2))
(ITIMES (fetch (RATIONAL NUMERATOR) of R1)
(fetch (RATIONAL DENOMINATOR) of R2)))
(ITIMES (fetch (RATIONAL DENOMINATOR) of R1)
(fetch (RATIONAL DENOMINATOR) of R2))))))
(\RMINUS
(LAMBDA (X) (* Pavel "24-Sep-86 18:51")
(if (type? RATIONAL X)
then (create RATIONAL
NUMERATOR ← (MINUS (fetch (RATIONAL NUMERATOR) of X))
DENOMINATOR ← (fetch (RATIONAL DENOMINATOR) 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)))
]
(* OK)
(DECLARE: EVAL@COMPILE
(PUTPROPS MASK.1'S MACRO (OPENLAMBDA (POSITION SIZE)
(LSH (SUB1 (LSH 1 SIZE))
POSITION)))
(PUTPROPS MASK.0'S MACRO (OPENLAMBDA (POSITION SIZE)
(LOGNOT (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 (LOGNOT MASK))))
)
(DEFOPTIMIZER LOGNOT (INTEGER) (BQUOTE (LOGXOR -1 (\, INTEGER))))
(DEFINEQ
(LOGNOT
(LAMBDA (INTEGER) (* kbr: "12-Jul-86 17:05")
(LOGXOR -1 INTEGER)))
)
(* "BYTE hacking functions")
[DECLARE: EVAL@COMPILE
(TYPERECORD BYTESPEC (BYTESPEC.SIZE BYTESPEC.POSITION))
]
(DEFINEQ
(LOADBYTE
[LAMBDA (N POS SIZE) (* lmm "12-Apr-85 14:35")
(\MACRO.MX (LOADBYTE N POS SIZE])
(DEPOSITBYTE
[LAMBDA (N POS SIZE VAL) (* lmm "12-Apr-85 14:36")
(\MACRO.MX (DEPOSITBYTE N POS SIZE VAL])
)
(DEFOPTIMIZER LOADBYTE (N POS SIZE) (BQUOTE (LOGAND (RSH (\, N)
(\, POS))
(MASK.1'S 0 (\, SIZE)))))
(DEFOPTIMIZER DEPOSITBYTE (&REST ARGS) (CONS (QUOTE (OPENLAMBDA (N POS SIZE VAL)
(LOGOR (BITCLEAR N (MASK.1'S POS SIZE))
(LSH (LOGAND VAL (MASK.1'S 0 SIZE))
POS))))
ARGS))
(DEFINEQ
(IMODLESSP
[LAMBDA (X Y MODULUS) (* lmm "12-Apr-85 12:43")
(ILESSP (IMODDIFFERENCE Y X MODULUS)
(FOLDHI MODULUS 2])
(IMODPLUS
[LAMBDA (X Y MODULUS) (* lmm "12-Apr-85 12:47")
(* tune for more efficiency later)
(\MACRO.MX (IMODPLUS X Y MODULUS])
(IMODDIFFERENCE
[LAMBDA (X Y MODULUS) (* lmm "12-Apr-85 12:48")
(\MACRO.MX (IMODDIFFERENCE X Y MODULUS])
)
(DEFOPTIMIZER IMOD (&REST L) (PROG ((N (CONSTANTEXPRESSIONP (CADR L))))
(if (NULL N)
then (RETURN (QUOTE IGNOREMACRO)))
(SETQ N (CAR N))
(RETURN (COND
((NOT (POWEROFTWOP N))
(QUOTE IGNOREMACRO))
(T (LIST (QUOTE LOGAND)
(CAR L)
(SUB1 N)))))))
(DEFOPTIMIZER IMODPLUS (X Y MODULUS) (BQUOTE (IMOD (IPLUS (\, X)
(\, Y))
(\, MODULUS))))
(DEFOPTIMIZER IMODDIFFERENCE (X Y MODULUS) (BQUOTE (IMOD (IDIFFERENCE (\, X)
(\, Y))
(\, MODULUS))))
(DEFINEQ
(ROT
[LAMBDA (X N FIELDSIZE) (* lmm "12-Apr-85 14:12")
(* Normalize N, the shift factor, into the half-open interval of 0 to FIELDSIZE and transform a negative N
(rotating rightwards) into a positive form.)
(LET* ((N (IMOD N FIELDSIZE))
(N.B (IDIFFERENCE FIELDSIZE N)))
(DEPOSITBYTE (LOADBYTE X N.B N)
N N.B X])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS .ROT. MACRO ((XFORM N FIELDSIZE)
((OPENLAMBDA (X)
(DEPOSITBYTE (LOADBYTE X (IDIFFERENCE FIELDSIZE N)
N)
N
(IDIFFERENCE FIELDSIZE N)
X))
XFORM)))
)
(* NOT OK YET)
(DEFOPTIMIZER BYTE (&REST X) (PROG ((SIZE (LISPFORM.SIMPLIFY (CAR X)
T))
(POSITION (LISPFORM.SIMPLIFY (CADR X)
T)))
(RETURN (COND
((AND (FIXP POSITION)
(FIXP SIZE))
(KWOTE (create BYTESPEC
BYTESPEC.SIZE ← SIZE
BYTESPEC.POSITION ← POSITION)))
(T (BQUOTE (create BYTESPEC
BYTESPEC.SIZE ← (\, SIZE)
BYTESPEC.POSITION ← (\, POSITION)))))
)))
(DEFOPTIMIZER DPB (&REST X) (\DPBEXPANDER X))
(DEFOPTIMIZER LDB (&REST X) (\LDBEXPANDER X))
(DECLARE: EVAL@COMPILE
(PUTPROPS BYTESIZE MACRO ((BYTESPEC)
(fetch BYTESPEC.SIZE of BYTESPEC)))
(PUTPROPS BYTEPOSITION MACRO ((BYTESPEC)
(fetch BYTESPEC.POSITION of BYTESPEC)))
)
(DEFINEQ
(LDB
(LAMBDA (BYTESPEC INTEGER) (* kbr: "12-Jul-86 17:10")
(LOADBYTE INTEGER (fetch (BYTESPEC BYTESPEC.POSITION) of BYTESPEC)
(fetch (BYTESPEC BYTESPEC.SIZE) of BYTESPEC))))
(DPB
(LAMBDA (NEWBYTE BYTESPEC INTEGER) (* kbr: "12-Jul-86 17:18")
(DEPOSITBYTE INTEGER (fetch (BYTESPEC BYTESPEC.POSITION) of BYTESPEC)
(fetch (BYTESPEC BYTESPEC.SIZE) of BYTESPEC)
NEWBYTE)))
(BYTE
(LAMBDA (SIZE POSITION) (* kbr: "14-Aug-86 14:18")
(create BYTESPEC
BYTESPEC.SIZE ← SIZE
BYTESPEC.POSITION ← POSITION)))
)
(DEFINEQ
(\LDBEXPANDER
(LAMBDA (X) (* kbr: "14-Aug-86 14:27")
(PROG (BS WORD TEM N SIZE POSITION) (* X = (BYTESPEC INTEGER) *)
(SETQ BS (LISPFORM.SIMPLIFY (CAR X)
T))
(SETQ WORD (CADR X))
(RETURN (COND
((AND (SETQ TEM (CAR (EVALUABLE.CONSTANTP BS)))
(type? BYTESPEC TEM))
(LIST (QUOTE LOADBYTE)
WORD
(KWOTE (BYTEPOSITION TEM))
(KWOTE (BYTESIZE TEM))))
(T (SETQ N (LISPFORM.SIMPLIFY WORD T))
(COND
((AND (LISTP BS)
(EQ (CAR BS)
(QUOTE BYTE)))
(SETQ SIZE (CADR BS))
(SETQ POSITION (CADDR BS))
(COND
((OR (EVALUABLE.CONSTANT.FIXP N)
(AND (ARGS.COMMUTABLEP N SIZE)
(ARGS.COMMUTABLEP N POSITION)
(ARGS.COMMUTABLEP SIZE POSITION)))
(BQUOTE (LOADBYTE (\, WORD)
(\, POSITION)
(\, SIZE))))
(T (BQUOTE ((LAMBDA (\Bytesize \Byteposition)
(DECLARE (LOCALVARS \Bytesize \Byteposition))
(LOADBYTE , WORD \Byteposition \Bytesize))
, SIZE , POSITION)))))
((AND (LITATOM BS)
(OR (EVALUABLE.CONSTANT.FIXP N)
(ARGS.COMMUTABLEP BS N)))
(BQUOTE (LOADBYTE , WORD (BYTEPOSITION , BS)
(BYTESIZE , BS))))
(T (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)))))
)
(* "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
(\PUTBASEBITS
[LAMBDA (ADDR POSITION SIZE VAL) (* lmm "12-Apr-85 15:18")
(if (GREATERP POSITION BITSPERWORD)
then (\PUTBASEBITS (\ADDBASE ADDR (FOLDLO POSITION BITSPERWORD))
(IMOD POSITION BITSPERWORD)
SIZE VAL)
elseif (GREATERP SIZE (DIFFERENCE BITSPERWORD POSITION))
then (* more than one word)
[\PUTBASEBITS ADDR POSITION (DIFFERENCE BITSPERWORD POSITION)
(RSH VAL (SETQ SIZE (DIFFERENCE SIZE (DIFFERENCE BITSPERWORD POSITION]
(\PUTBASEBITS (\ADDBASE ADDR 1)
0 SIZE VAL)
else (* a single word)
(\PUTBASE ADDR 0 (DEPOSITBYTE (\GETBASE ADDR 0)
(DIFFERENCE (SUB1 BITSPERWORD)
POSITION)
SIZE 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))))
)
)
(PUTPROPS ADDARITH FILETYPE COMPILE-FILE)
(PUTPROPS ADDARITH COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3312 9293 (\RTIMES2 3322 . 5322) (\RATIONALIZE 5324 . 5659) (\RPLUS2 5661 . 7492) (
\RMINUS 7494 . 7873) (CREATERATIONAL 7875 . 9045) (RATIONALTOINTEGER 9047 . 9291)) (10185 10330 (
LOGNOT 10195 . 10328)) (10455 10771 (LOADBYTE 10465 . 10611) (DEPOSITBYTE 10613 . 10769)) (11403 12004
(IMODLESSP 11413 . 11592) (IMODPLUS 11594 . 11841) (IMODDIFFERENCE 11843 . 12002)) (13083 13514 (ROT
13093 . 13512)) (15325 16076 (LDB 15335 . 15589) (DPB 15591 . 15867) (BYTE 15869 . 16074)) (16077
21247 (\LDBEXPANDER 16087 . 18574) (\DPBEXPANDER 18576 . 21245)) (21598 22525 (\PUTBASEBITS 21608 .
22523)) (26696 27354 (\GETBASENIBBLE 26706 . 26867) (\PUTBASENIBBLE 26869 . 27034) (\GETBASEBIT 27036
. 27191) (\PUTBASEBIT 27193 . 27352)))))
STOP