(FILECREATED " 1-May-84 22:48:45" {PHYLUM}<LISPCORE>SOURCES>LLARITH.;7 130540Q
changes to: (MACROS \IQUOTREM .NEGATE.)
(FNS IEQP)
previous date: "29-Mar-84 15:50:05" {PHYLUM}<LISPCORE>SOURCES>LLARITH.;6)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LLARITHCOMS)
(RPAQQ LLARITHCOMS ((LOCALVARS . T)
(COMS (* OPCODES)
(FNS IDIFFERENCE IGREATERP IQUOTIENT)
(FNS \SLOWIPLUS2 \SLOWIDIFFERENCE \SLOWIGREATERP \SLOWLLSH1 \SLOWLLSH8
\SLOWLOGAND2 \SLOWLOGOR2 \SLOWLOGXOR2 \SLOWLRSH1 \SLOWLRSH8
\SLOWITIMES2 \SLOWIQUOTIENT))
(COMS (* IPLUS and IDIFFERENCE that smash result into their first arg)
(FNS \BOXIPLUS \BOXIDIFFERENCE))
(* subfunctions)
(FNS \MAKENUMBER)
(FNS OVERFLOW)
(VARS (\OVERFLOW 0))
(E (RESETSAVE (RADIX 8)))
(CONSTANTS (MAX.SMALLP 65535)
(MIN.SMALLP -65536)
(MAX.FIXP 2147483647)
(MIN.FIXP -2147483648)
(\SIGNBIT 32768))
(* Someday these two names should be flushed -- JonL 7/25/83)
(CONSTANTS (MAX.INTEGER 2147483647)
(MIN.INTEGER -2147483648))
(EXPORT (DECLARE: DONTCOPY (RECORDS FIXP)
(CONSTANTS (MAX.SMALL.INTEGER 65535)
(MAX.POS.HINUM 32767))
(MACROS .UNBOX. .NEGATE. .LLSH1. .LRSH1. .BOXIPLUS.)))
(FNS EQP FIX IQUOTIENT IREMAINDER LLSH LRSH LSH RSH)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS NBITS.OR.LESS .SUBSMALL. \IQUOTREM))
(* machine independent arithmetic functions)
(FNS MINUSP ILESSP IMINUS IPLUS ITIMES LOGAND LOGOR LOGXOR SUB1 ZEROP ADD1 GCD
IEQP INTEGERLENGTH)
(FNS ABS DIFFERENCE GREATERP PLUS QUOTIENT REMAINDER LESSP MINUS TIMES)
(FNS FMINUS FREMAINDER)
(FNS RANDSET RAND SQRT EXPT IEXPT)
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (RANDSTATE)
(\TOL 9.999992E-6)))
(GLOBALVARS RANDSTATE \TOL)
(COMS (* ugly hacks)
(FNS PutUnboxed \PUTFIXP \PUTSWAPPEDFIXP \HINUM \LONUM TRUNCATEMULTIPLY)
(EXPORT (DECLARE: DONTCOPY (MACROS PutUnboxed))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA TIMES PLUS LOGXOR LOGOR LOGAND ITIMES IPLUS)))))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(* OPCODES)
(DEFINEQ
(IDIFFERENCE
[LAMBDA (X Y) (* lmm "11-FEB-82 14:02")
((OPCODES IDIFFERENCE)
X Y])
(IGREATERP
[LAMBDA (X Y) (* lmm "11-FEB-82 14:02")
((OPCODES IGREATERP)
X Y])
(IQUOTIENT
[LAMBDA (X Y) (* lmm "11-FEB-82 14:02")
((OPCODES IQUOTIENT)
X Y])
)
(DEFINEQ
(\SLOWIPLUS2
[LAMBDA (X Y) (* lmm "13-OCT-82 15:27")
(PROG (HX LX HY LY SIGNX)
(.UNBOX. X HX LX)
(.UNBOX. Y HY LY)
(SETQ SIGNX (IGREATERP HX MAX.POS.HINUM))
[SETQ HX (COND
[(IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
(IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY]
(T (IPLUS HX HY] (* Add high parts)
[SETQ LX (COND
[(IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
(* Carry into high part.)
[SETQ HX (COND
((EQ HX MAX.SMALL.INTEGER)
0)
(T (ADD1 HX]
(IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY]
(T (IPLUS LX LY]
(COND
((AND (EQ SIGNX (IGREATERP HY MAX.POS.HINUM))
(NEQ SIGNX (IGREATERP HX MAX.POS.HINUM)))
(* overflow occurs if X and Y are same sign, but result
is opposite sign)
(SELECTQ \OVERFLOW
(T (LISPERROR "OVERFLOW" (\MAKENUMBER HX LX)))
[NIL (* return max/min)
(RETURN (COND
(SIGNX MIN.INTEGER)
(T MAX.INTEGER]
NIL)))
(RETURN (\MAKENUMBER HX LX])
(\SLOWIDIFFERENCE
[LAMBDA (X Y) (* lmm "27-JUN-83 15:37")
(PROG (HX LX HY LY SIGNX)
(.UNBOX. X HX LX)
(.UNBOX. Y HY LY) (* Allow this unboxing before the following test so that
error checking will be performed on Y)
[COND
((EQ Y 0)
(RETURN (\MAKENUMBER HX LX]
(.NEGATE. HY LY)
(SETQ SIGNX (IGREATERP HX MAX.POS.HINUM))
(COND
([COND
((AND (ZEROP LY)
(EQ HY \SIGNBIT)) (* Y = -Y = Min.integer. Overflow occurs if X is
positive)
(SETQ HX (LOGXOR HX HY))
(NOT SIGNX))
(T [SETQ HX (COND
[(IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
(IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY]
(T (IPLUS HX HY] (* Add high parts)
[SETQ LX (COND
[(IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
(* Carry into high part.)
[SETQ HX (COND
((EQ HX MAX.SMALL.INTEGER)
0)
(T (ADD1 HX]
(IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY]
(T (IPLUS LX LY] (* overflow occurs if X and Y are same sign, but result
is opposite sign)
(AND (EQ SIGNX (IGREATERP HY MAX.POS.HINUM))
(NEQ SIGNX (IGREATERP HX MAX.POS.HINUM]
(SELECTQ \OVERFLOW
(T (LISPERROR "OVERFLOW" (\MAKENUMBER HX LX)))
[NIL (* return max/min)
(RETURN (COND
(SIGNX MIN.INTEGER)
(T MAX.INTEGER]
NIL)))
(RETURN (\MAKENUMBER HX LX])
(\SLOWIGREATERP
[LAMBDA (X Y) (* lmm "14-APR-81 16:44")
(PROG (HX LX HY LY)
(.UNBOX. X HX LX)
(.UNBOX. Y HY LY)
(RETURN (COND
((EQ HX HY)
(IGREATERP LX LY))
(T (IGREATERP (LOGXOR HX \SIGNBIT)
(LOGXOR HY \SIGNBIT])
(\SLOWLLSH1
[LAMBDA (X) (* lmm "13-OCT-82 15:27")
(PROG (LO HI)
(.UNBOX. X HI LO)
(RETURN (\MAKENUMBER (IPLUS (LLSH (LOGAND HI 77777Q)
1)
(COND
((IGREATERP LO 77777Q)
1)
(T 0)))
(LLSH (LOGAND LO 77777Q)
1])
(\SLOWLLSH8
[LAMBDA (X) (* lmm "13-OCT-82 15:28")
(PROG (HI LO)
(.UNBOX. X HI LO)
(RETURN (\MAKENUMBER (IPLUS (LLSH (LOGAND HI 377Q)
10Q)
(LRSH LO 10Q))
(LLSH (LOGAND LO 377Q)
10Q])
(\SLOWLOGAND2
[LAMBDA (A B) (* lmm "13-OCT-82 15:29")
(PROG (AH AL BH BL)
(.UNBOX. A AH AL)
(.UNBOX. B BH BL)
(RETURN (\MAKENUMBER (LOGAND AH BH)
(LOGAND AL BL])
(\SLOWLOGOR2
[LAMBDA (A B) (* lmm "13-OCT-82 15:29")
(PROG (AH AL BH BL)
(.UNBOX. A AH AL)
(.UNBOX. B BH BL)
(RETURN (\MAKENUMBER (LOGOR AH BH)
(LOGOR AL BL])
(\SLOWLOGXOR2
[LAMBDA (A B) (* lmm "13-OCT-82 15:29")
(PROG (AH AL BH BL)
(.UNBOX. A AH AL)
(.UNBOX. B BH BL)
(RETURN (\MAKENUMBER (LOGXOR AH BH)
(LOGXOR AL BL])
(\SLOWLRSH1
[LAMBDA (X) (* lmm "13-OCT-82 15:29")
(PROG (HI LO)
(.UNBOX. X HI LO)
(RETURN (\MAKENUMBER (LRSH HI 1)
(IPLUS (LRSH LO 1)
(COND
((ZEROP (LOGAND HI 1))
0)
(T 100000Q])
(\SLOWLRSH8
[LAMBDA (X) (* lmm "13-OCT-82 15:29")
(PROG (HI LO)
(.UNBOX. X HI LO)
(RETURN (\MAKENUMBER (LRSH HI 10Q)
(IPLUS (LLSH (LOGAND HI 377Q)
10Q)
(LRSH LO 10Q])
(\SLOWITIMES2
[LAMBDA (X Y) (* lmm "13-OCT-82 15:27")
(COND
((OR (EQ X 0)
(EQ Y 0))
0)
(T (PROG (HX HY LX LY SIGN (HR 0)
(LR 0)
CARRY)
(.UNBOX. X HX LX)
(.UNBOX. Y HY LY)
(COND
((IGREATERP HX MAX.POS.HINUM)
(.NEGATE. HX LX)
(SETQ SIGN T)))
[COND
((IGREATERP HY MAX.POS.HINUM)
(.NEGATE. HY LY)
(SETQ SIGN (NOT SIGN]
(COND
((NEQ HY 0)
(COND
((NEQ HX 0)
(GO OVER)))
(swap LX LY)
(swap HX HY)))
MLP [COND
((NEQ (LOGAND LY 1)
0)
(COND
((IGREATERP LR (IDIFFERENCE MAX.SMALL.INTEGER LX))
(* low parts overflow)
(* make the low word be the less significant bits and
return the carry.)
[SETQ LR (IDIFFERENCE LR (IDIFFERENCE MAX.SMALL.INTEGER (SUB1 LX]
(SETQ CARRY 1))
(T (* no carry just add the low halves.)
(SETQ LR (IPLUS LR LX))
(SETQ CARRY 0)))
(* the low order part of the answer has been set and CARRY is the numeric value of the carry from the low part
either 0 or 1)
(AND (IGREATERP (SETQ HR (IPLUS HR HX CARRY))
MAX.POS.HINUM)
(GO OVER]
(COND
((ZEROP (SETQ LY (LRSH LY 1)))
(GO RET)))
(.LLSH1. HX LX)
(COND
((IGREATERP HX MAX.POS.HINUM)
(GO OVER)))
(GO MLP)
OVER[SELECTQ \OVERFLOW
(T (LISPERROR "OVERFLOW" (\MAKENUMBER HR LR)))
[NIL (RETURN (COND
((NULL SIGN)
MAX.INTEGER)
(T MIN.INTEGER]
(PROGN (* truncate -
this is awful code, but it works)
(RETURN (TRUNCATEMULTIPLY X Y]
RET (COND
(SIGN (.NEGATE. HR LR)))
(RETURN (\MAKENUMBER HR LR])
(\SLOWIQUOTIENT
[LAMBDA (X Y) (* edited: "29-APR-82 05:01")
(\IQUOTREM X Y X)
X])
)
(* IPLUS and IDIFFERENCE that smash result into their first arg)
(DEFINEQ
(\BOXIPLUS
[LAMBDA (X Y) (* lmm "13-OCT-82 16:02")
(.BOXIPLUS. (\DTEST X (QUOTE FIXP))
Y])
(\BOXIDIFFERENCE
[LAMBDA (X Y) (* bvm: "10-JUN-82 16:10")
(PROG ((HX (\GETBASE (\DTEST X (QUOTE FIXP))
0))
(LX (\GETBASE X 1))
HY LY)
(.UNBOX. Y HY LY)
(.NEGATE. HY LY)
[SETQ HX (COND
[(IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
(IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY]
(T (IPLUS HX HY] (* Add high parts)
[\PUTBASE X 1 (COND
[(IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
(* Carry into high part.)
[SETQ HX (COND
((EQ HX MAX.SMALL.INTEGER)
0)
(T (ADD1 HX]
(IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY]
(T (IPLUS LX LY]
(\PUTBASE X 0 HX)
(RETURN X])
)
(* subfunctions)
(DEFINEQ
(\MAKENUMBER
(LAMBDA (N0 N1) (* JonL " 1-Jan-84 00:11")
(* used as punt case for arith opcodes which create
large numbers)
(SETQ N1 (.COERCE.TO.SMALLPOSP. N1))
(SELECTC (SETQ N0 (.COERCE.TO.SMALLPOSP. N0))
(0 N1)
(65535 (* This is a word's worth of 1 bits)
(\VAG2 \SmallNegHi N1))
(create FIXP
HINUM ← N0
LONUM ← N1))))
)
(DEFINEQ
(OVERFLOW
[LAMBDA (FLG) (* lmm: 14-JAN-76 1 6)
(PROG1 \OVERFLOW (SETQ \OVERFLOW (SELECTQ FLG
(NIL NIL)
(T T)
0])
)
(RPAQQ \OVERFLOW 0)
(DECLARE: EVAL@COMPILE
(RPAQQ MAX.SMALLP 177777Q)
(RPAQQ MIN.SMALLP -200000Q)
(RPAQQ MAX.FIXP 17777777777Q)
(RPAQQ MIN.FIXP -20000000000Q)
(RPAQQ \SIGNBIT 100000Q)
(CONSTANTS (MAX.SMALLP 177777Q)
(MIN.SMALLP -200000Q)
(MAX.FIXP 17777777777Q)
(MIN.FIXP -20000000000Q)
(\SIGNBIT 100000Q))
)
(* Someday these two names should be flushed -- JonL 7/25/83)
(DECLARE: EVAL@COMPILE
(RPAQQ MAX.INTEGER 17777777777Q)
(RPAQQ MIN.INTEGER -20000000000Q)
(CONSTANTS (MAX.INTEGER 17777777777Q)
(MIN.INTEGER -20000000000Q))
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD FIXP ((HINUM WORD)
(LONUM WORD))
(CREATE (CREATECELL \FIXP))
(TYPE? (EQ (NTYPX DATUM)
\FIXP)))
]
(DECLARE: EVAL@COMPILE
(RPAQQ MAX.SMALL.INTEGER 177777Q)
(RPAQQ MAX.POS.HINUM 77777Q)
(CONSTANTS (MAX.SMALL.INTEGER 177777Q)
(MAX.POS.HINUM 77777Q))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS .UNBOX. MACRO ((V HV LV)
(PROG NIL
UBLP(SELECTC (NTYPX V)
(\FIXP (SETQ HV (fetch (FIXP HINUM) of V))
(SETQ LV (fetch (FIXP LONUM) of V)))
(\SMALLP (COND
((SMALLPOSP V)
(SETQ HV 0)
(SETQ LV V))
(T (SETQ HV 177777Q)
(SETQ LV (LOLOC V)))))
(\FLOATP (SETQ V (\FIXP.FROM.FLOATP V))
(GO UBLP))
(PROGN (SETQ V (LISPERROR "NON-NUMERIC ARG" V))
(GO UBLP))))))
(PUTPROPS .NEGATE. MACRO ((HY LY)
(COND
((EQ 0 LY)
(AND (NEQ HY 0)
(SETQ HY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY)))))
(T (SETQ HY (IDIFFERENCE MAX.SMALL.INTEGER HY))
(SETQ LY (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY)))))))
(PUTPROPS .LLSH1. MACRO ((HI LO)
(* shift the pair left one, assuming no overflow)
(SETQ HI (LLSH HI 1))
(SETQ LO (LLSH (COND
((IGREATERP LO MAX.POS.HINUM)
(add HI 1)
(LOGAND LO MAX.POS.HINUM))
(T LO))
1))))
(PUTPROPS .LRSH1. MACRO ((HI LO)
(SETQ LO (LRSH LO 1))
(COND
((NEQ (LOGAND HI 1)
0)
(SETQ LO (IPLUS LO \SIGNBIT))))
(SETQ HI (LRSH HI 1))))
(PUTPROPS .BOXIPLUS. MACRO (OPENLAMBDA (X Y)
(PROG ((HX (\GETBASE X 0))
(LX (\GETBASE X 1))
HY LY)
(.UNBOX. Y HY LY)
(SETQ HX (COND
((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
(IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))))
(T (IPLUS HX HY)))) (* Add high parts)
(\PUTBASE X 1 (COND
((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
(* Carry into high part.)
(SETQ HX (COND
((EQ HX MAX.SMALL.INTEGER)
0)
(T (ADD1 HX))))
(IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY))))
(T (IPLUS LX LY))))
(\PUTBASE X 0 HX)
(RETURN X))))
)
)
(* END EXPORTED DEFINITIONS)
(DEFINEQ
(EQP
[LAMBDA (X Y) (* lmm "21-JAN-82 08:20")
(COND
((EQ X Y))
[(AND (NUMBERP X)
(NUMBERP Y))
(COND
((OR (FLOATP X)
(FLOATP Y))
(FEQP X Y))
(T (IEQP X Y]
((EQ (NTYPX X)
(NTYPX Y))
(SELECTC (NTYPX X)
(\STACKP (EQ (fetch (STACKP EDFXP) of X)
(fetch (STACKP EDFXP) of Y)))
(\ARRAYP (AND (EQ (fetch (ARRAYP TYP) of X)
\ST.CODE)
(EQDEFP X Y)))
NIL))
(T NIL])
(FIX
[LAMBDA (N) (* lmm "18-APR-80 18:08")
(* FIX compiles open)
(IPLUS N 0])
(IQUOTIENT
[LAMBDA (X Y) (* lmm "11-FEB-82 14:02")
((OPCODES IQUOTIENT)
X Y])
(IREMAINDER
[LAMBDA (X Y) (* edited: "29-APR-82 05:01")
(\IQUOTREM X Y NIL Y)
Y])
(LLSH
[LAMBDA (X N) (* lmm "13-OCT-82 15:30")
(COND
((IGREATERP 0 N)
(LRSH X (IMINUS N)))
(T (PROG (XHI XLO)
(.UNBOX. X XHI XLO)
(COND
((IGREATERP N 37Q)
(RETURN 0)))
[COND
((IGREATERP N 17Q)
(SETQ XHI XLO)
(SETQ XLO 0)
(SETQ N (IDIFFERENCE N 20Q]
[COND
((IGREATERP N 7)
(SETQ XHI (IPLUS (LLSH (LOGAND XHI 377Q)
10Q)
(LRSH XLO 10Q)))
(SETQ XLO (LLSH (LOGAND XLO 377Q)
10Q))
(SETQ N (IDIFFERENCE N 10Q]
(FRPTQ N (SETQ XHI (LOGAND XHI MAX.POS.HINUM))
(.LLSH1. XHI XLO))
(RETURN (\MAKENUMBER XHI XLO])
(LRSH
[LAMBDA (X N) (* lmm "13-OCT-82 15:30")
(* assumes case where n is constant and 10Q or 1 handled
in microcode or by \SLOWLRSHn)
(COND
((IGREATERP 0 N)
(LLSH X (IMINUS N)))
(T (PROG (XHI XLO)
(.UNBOX. X XHI XLO)
(COND
((IGREATERP N 37Q)
(RETURN 0)))
[COND
((IGREATERP N 17Q)
(SETQ XLO XHI)
(SETQ XHI 0)
(SETQ N (IDIFFERENCE N 20Q]
[COND
((IGREATERP N 7)
(SETQ XLO (IPLUS (LRSH XLO 10Q)
(LLSH (LOGAND XHI 377Q)
10Q)))
(SETQ XHI (LRSH XHI 10Q))
(SETQ N (IDIFFERENCE N 10Q]
(FRPTQ N (.LRSH1. XHI XLO))
(RETURN (\MAKENUMBER XHI XLO])
(LSH
[LAMBDA (X N) (* lmm "13-OCT-82 15:30")
(COND
[(ILEQ N 0)
(COND
((EQ N 0)
X)
(T (RSH X (IMINUS N]
((IGREATERP N (CONSTANT (DIFFERENCE (TIMES 2 BITSPERWORD)
2))) (* Shifting more than the non-sign bits just returns the
sign bit)
(COND
((MINUSP X) (* X was negative)
(AND (EQ \OVERFLOW T)
(NEQ X -1)
(LISPERROR "OVERFLOW" (CONSTANT MIN.INTEGER)))
(CONSTANT MIN.INTEGER))
(T (AND (EQ \OVERFLOW T)
(NEQ X 0)
(LISPERROR "OVERFLOW" 0))
0)))
(T (PROG (XHI XLO (XSIGNBIT 0))
(.UNBOX. X XHI XLO)
(COND
((IGEQ XHI \SIGNBIT)
(SETQ XSIGNBIT \SIGNBIT)))
[COND
((IGEQ N (CONSTANT BITSPERWORD))
(AND (EQ \OVERFLOW T)
[COND
((EQ XSIGNBIT 0)
(OR (NEQ XHI 0)
(NEQ (LOGAND XLO \SIGNBIT)
0)))
(T (OR (NEQ XHI MAX.SMALL.INTEGER)
(EQ (LOGAND XLO \SIGNBIT)
0]
(LISPERROR "OVERFLOW" X))
(SETQ XHI XLO)
(SETQ XLO 0)
(SETQ N (IDIFFERENCE N (CONSTANT BITSPERWORD]
(* N must be less than BITSPERWORD, i.e. 16, now)
[COND
((IGREATERP N 7)
(PROGN (AND (EQ \OVERFLOW T)
(NEQ (LOGAND XHI 77400Q)
(COND
((NEQ XSIGNBIT 0)
77400Q)
(T 0)))
(LISPERROR "OVERFLOW" X))
(SETQ XHI (LOGOR (LLSH XHI 10Q)
(LRSH XLO 10Q)))
(SETQ XLO (LLSH (LOGAND XLO 377Q)
10Q))
(SETQ N (IDIFFERENCE N 10Q]
(FRPTQ N (AND (EQ \OVERFLOW T)
(COND
((ZEROP (LOGAND XHI 40000Q))
(NEQ XSIGNBIT 0))
(T (EQ XSIGNBIT 0)))
(LISPERROR "OVERFLOW" X))
[SETQ XHI (COND
((ZEROP (LOGAND XLO \SIGNBIT))
(LLSH XHI 1))
(T (* Flush the high-order bit, so subsequent LSH of XLO
won't overflow the SMALLP range)
(SETQ XLO (LOGXOR XLO \SIGNBIT))
(LOGOR (LLSH XHI 1)
1]
(SETQ XLO (LLSH XLO 1)))
(SETQ XHI (LOGOR XSIGNBIT (LOGAND XHI MAX.POS.HINUM)))
(RETURN (\MAKENUMBER XHI XLO])
(RSH
[LAMBDA (X N) (* lmm "13-OCT-82 15:30")
(COND
((IGREATERP 0 N)
(LSH X (IMINUS N)))
(T (PROG (XHI XLO)
(.UNBOX. X XHI XLO)
[COND
((IGREATERP N 37Q)
(RETURN (COND
((IGREATERP XHI 77777Q) (* X WAS NEGATIVE)
-1)
(T 0]
[COND
((IGREATERP N 17Q)
(SETQ XLO XHI)
(SETQ XHI (COND
((IGREATERP XHI 77777Q)
177777Q)
(T 0)))
(SETQ N (IDIFFERENCE N 20Q]
[COND
((IGREATERP N 7)
(SETQ XLO (IPLUS (LRSH XLO 10Q)
(LLSH (LOGAND XHI 377Q)
10Q)))
[SETQ XHI (IPLUS (LRSH XHI 10Q)
(COND
((IGREATERP XHI 77777Q)
177400Q)
(T 0]
(SETQ N (IDIFFERENCE N 10Q]
[FRPTQ N [SETQ XLO (IPLUS (LRSH XLO 1)
(COND
((ZEROP (LOGAND XHI 1))
0)
(T 100000Q]
(SETQ XHI (IPLUS (LRSH XHI 1)
(LOGAND XHI 100000Q]
(RETURN (\MAKENUMBER XHI XLO])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS NBITS.OR.LESS MACRO ((X N)
(ILESSP X (CONSTANT (LLSH 1 N)))))
(PUTPROPS .SUBSMALL. MACRO ((X Y)
(* Subtract Y from X, returning the borrow out of the
next word)
(COND
((ILEQ Y X)
(SETQ X (IDIFFERENCE X Y))
0)
(T (SETQ X (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X))))
1))))
(PUTPROPS \IQUOTREM MACRO ((X Y QUO REM)
(PROG (HX LX HY LY SIGNQUOTIENT SIGNREMAINDER (CNT 0)
(HZ 0)
(LZ 0))
(.UNBOX. X HX LX)
(.UNBOX. Y HY LY)
(COND
((IGREATERP HX MAX.POS.HINUM)
(.NEGATE. HX LX)
(SETQ SIGNQUOTIENT (SETQ SIGNREMAINDER T)))) (* Remainder has sign of dividend)
(COND
((IGREATERP HY MAX.POS.HINUM)
(.NEGATE. HY LY)
(SETQ SIGNQUOTIENT (NOT SIGNQUOTIENT))))
(COND
((NEQ HX 0)
(GO BIGDIVIDEND))
((NEQ HY 0) (* Y is big, X is small, so result is 0)
(GO DONE))
((EQ 0 LX)
(GO RET0))
((EQ 0 LY)
(GO DIVZERO))
((EQ LY 1)
(SETQ LZ LX)
(SETQ LX 0)
(GO DONE))) (* here we are dividing small X by small Y, and we know
Y gt 1)
LP1 (* shift Y left until it is as big as X, and count how
many times)
(COND
((AND (ILESSP LY LX)
(ILEQ LY MAX.POS.HINUM))
(SETQ LY (LLSH LY 1))
(SETQ CNT (ADD1 CNT))
(GO LP1)))
LP2 (* now start dividing Y into X by subtracting and
shifting, ending up with Y shifted back where it
started)
(COND
((ILEQ LY LX)
(SETQ LX (IDIFFERENCE LX LY)) (* Y divides X once, so add bit into quotient)
(SETQ LZ (ADD1 LZ))))
(SETQ LY (LRSH LY 1))
(SETQ CNT (SUB1 CNT))
(COND
((IGEQ CNT 0)
(SETQ LZ (LLSH LZ 1))
(GO LP2)))
(GO DONE)
BIGDIVIDEND (* X is big, so result may be big.
Algorithm is same as above, but everything is doubled in
length)
(COND
((EQ 0 HY)
(COND
((EQ 0 (SETQ HY LY))
(GO DIVZERO))
((AND SIGNREMAINDER (NULL SIGNQUOTIENT)
(EQ 1 LY)
(EQ HX \SIGNBIT)
(EQ 0 LX)) (* Means that X is MIN.FIXP and Y is -1)
(SELECTQ \OVERFLOW
(T (ERROR "DIVISION OVERFLOW" Y))
(GO RET0))))
(SETQ LY 0)
(SETQ CNT 20Q))
((AND SIGNREMAINDER (NULL SIGNQUOTIENT)
(EQ 0 LX)
(EQ HX \SIGNBIT)
(EQ 0 HY)
(EQ 1 LY)) (* Means that X is MIN.FIXP and Y is -1)
(SELECTQ \OVERFLOW
(T (ERROR "DIVISION OVERFLOW" Y))
(GO RET0))))
BIGLP
(COND
((AND (OR (AND (EQ HY HX)
(ILESSP LY LX))
(ILESSP HY HX))
(ILESSP HY MAX.POS.HINUM))
(.LLSH1. HY LY)
(SETQ CNT (ADD1 CNT))
(GO BIGLP)))
BIGLP2
(COND
((OR (ILESSP HY HX)
(AND (EQ HY HX)
(ILEQ LY LX))) (* Y divides X, so subtract Y from X and put a bit in
quotient)
(SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY)
(.SUBSMALL. LX LY)))
(SETQ LZ (ADD1 LZ)) (* note that this never overflows, because of the
preceding left shift)
))
(.LRSH1. HY LY)
(SETQ CNT (SUB1 CNT))
(COND
((IGEQ CNT 0)
(.LLSH1. HZ LZ)
(GO BIGLP2)))
DONE(COND
(REM (* remainder is left in X)
(COND
(SIGNREMAINDER (.NEGATE. HX LX)))
(SETQ REM (\MAKENUMBER HX LX))))
(COND
(QUO (COND
(SIGNQUOTIENT (.NEGATE. HZ LZ)))
(SETQ QUO (\MAKENUMBER HZ LZ))))
(RETURN)
DIVZERO
(SELECTQ \OVERFLOW
(T (ERROR "DIVIDE BY ZERO" Y))
(GO RET0))
RET0(COND
(REM (SETQ REM 0)))
(COND
(QUO (SETQ QUO 0)))
(RETURN))))
)
)
(* machine independent arithmetic functions)
(DEFINEQ
(MINUSP
[LAMBDA (X) (* lmm "17-DEC-80 20:56")
(COND
((FLOATP X)
(FGREATERP 0.0 X))
(T (IGREATERP 0 X])
(ILESSP
[LAMBDA (X Y)
(IGREATERP Y X])
(IMINUS
[LAMBDA (X)
(IDIFFERENCE 0 X])
(IPLUS
[LAMBDA N (* lmm " 2-MAR-82 10:05")
(* called only by interpreted code -
this defn relies on fact that compiler turns IPLUS calls
into sequences of opcodes)
(SELECTQ N
(2 (IPLUS (ARG N 1)
(ARG N 2)))
(1 (IPLUS (ARG N 1)))
(0 (IPLUS))
(PROG ((R (IPLUS (ARG N 1)
(ARG N 2)
(ARG N 3)))
(J 4))
LP (COND
((ILEQ J N)
(SETQ R (IPLUS R (ARG N J)))
(SETQ J (ADD1 J))
(GO LP)))
(RETURN R])
(ITIMES
[LAMBDA N (* lmm " 2-MAR-82 10:05")
(* called only by interpreted code -
this defn relies on fact that compiler turns ITIMES
calls into sequences of opcodes)
(SELECTQ N
(2 (ITIMES (ARG N 1)
(ARG N 2)))
(1 (ITIMES (ARG N 1)))
(0 (ITIMES))
(PROG ((R (ITIMES (ARG N 1)
(ARG N 2)
(ARG N 3)))
(J 4))
LP (COND
((ILEQ J N)
(SETQ R (ITIMES R (ARG N J)))
(SETQ J (ADD1 J))
(GO LP)))
(RETURN R])
(LOGAND
[LAMBDA N (* lmm " 2-MAR-82 10:05")
(* called only by interpreted code -
this defn relies on fact that compiler turns LOGAND
calls into sequences of opcodes)
(SELECTQ N
(2 (LOGAND (ARG N 1)
(ARG N 2)))
(1 (LOGAND (ARG N 1)))
(0 (LOGAND))
(PROG ((R (LOGAND (ARG N 1)
(ARG N 2)
(ARG N 3)))
(J 4))
LP (COND
((ILEQ J N)
(SETQ R (LOGAND R (ARG N J)))
(SETQ J (ADD1 J))
(GO LP)))
(RETURN R])
(LOGOR
[LAMBDA N (* lmm " 2-MAR-82 10:05")
(* called only by interpreted code -
this defn relies on fact that compiler turns LOGOR calls
into sequences of opcodes)
(SELECTQ N
(2 (LOGOR (ARG N 1)
(ARG N 2)))
(1 (LOGOR (ARG N 1)))
(0 (LOGOR))
(PROG ((R (LOGOR (ARG N 1)
(ARG N 2)
(ARG N 3)))
(J 4))
LP (COND
((ILEQ J N)
(SETQ R (LOGOR R (ARG N J)))
(SETQ J (ADD1 J))
(GO LP)))
(RETURN R])
(LOGXOR
[LAMBDA N (* lmm " 2-MAR-82 10:05")
(* called only by interpreted code -
this defn relies on fact that compiler turns LOGXOR
calls into sequences of opcodes)
(SELECTQ N
(2 (LOGXOR (ARG N 1)
(ARG N 2)))
(1 (LOGXOR (ARG N 1)))
(0 (LOGXOR))
(PROG ((R (LOGXOR (ARG N 1)
(ARG N 2)
(ARG N 3)))
(J 4))
LP (COND
((ILEQ J N)
(SETQ R (LOGXOR R (ARG N J)))
(SETQ J (ADD1 J))
(GO LP)))
(RETURN R])
(SUB1
[LAMBDA (X) (* lmm " 5-MAR-80 23:07")
(IDIFFERENCE X 1])
(ZEROP
[LAMBDA (X)
(EQ X 0])
(ADD1
[LAMBDA (X)
(IPLUS X 1])
(GCD
[LAMBDA (N1 N2) (* edited: "22-APR-82 05:26")
(COND
((ZEROP N2)
N1)
((MINUSP N2)
(GCD (MINUS N2)
N1))
(T (GCD N2 (IREMAINDER N1 N2])
(IEQP
(LAMBDA (X Y) (* JonL " 1-May-84 22:23")
(EQ 0 (IDIFFERENCE X Y))))
(INTEGERLENGTH
(LAMBDA (X) (* JonL "18-OCT-82 21:51")
(SELECTQ (SYSTEMTYPE)
(D (* Foo, INTEGERLENGTH currently "boxes" on negative
arguments)
(SELECTC (NTYPX X)
(\SMALLP (COND
((ILESSP X 0)
(SETQ X (MINUS X))))
(COND
((NBITS.OR.LESS X 20Q)
(COND
((NBITS.OR.LESS X 10Q)
(COND
((NBITS.OR.LESS X 4)
(COND
((NBITS.OR.LESS X 2)
(COND
((NBITS.OR.LESS X 1)
(COND
((EQ X 0)
0)
(T 1)))
(T 2)))
((NBITS.OR.LESS X 3)
3)
(T 4)))
((NBITS.OR.LESS X 6)
(COND
((NBITS.OR.LESS X 5)
5)
(T 6)))
((NBITS.OR.LESS X 7)
7)
(T 10Q)))
((NBITS.OR.LESS X 14Q)
(COND
((NBITS.OR.LESS X 12Q)
(COND
((NBITS.OR.LESS X 11Q)
11Q)
(T 12Q)))
((NBITS.OR.LESS X 13Q)
13Q)
(T 14Q)))
((NBITS.OR.LESS X 16Q)
(COND
((NBITS.OR.LESS X 15Q)
15Q)
(T 16Q)))
((NBITS.OR.LESS X 17Q)
17Q)
(T 20Q)))
(T (SHOULDNT))))
(\FIXP (PROG ((HX (fetch (FIXP HINUM) of X)))
(if (IGREATERP HX MAX.POS.HINUM)
then (* So X is negative)
((LAMBDA (LX)
(if (AND (EQ HX \SIGNBIT)
(EQ LX 0))
then
(* So X is EQP to the minimum FIXP integer)
(RETURN (CONSTANT BITS.PER.FIXP))
else (.NEGATE. HX LX)))
(fetch (FIXP LONUM) of X)))
(RETURN (if (EQ HX 0)
then
(* This bizarre case shouldn't really happen, but I wouldn't like to rule it out -- a non-normalized FIXP that
realy should be a SMALLP)
(INTEGERLENGTH (fetch (FIXP LONUM)
of X))
else (IPLUS (INTEGERLENGTH HX)
BITSPERWORD)))))
(PROGN
(* Someday we'd like (COND ((OPEN-BIGNUMP X) (SETQ X (BNDS X)) (LET* ((N (SUB1 (BNDS-LENGTH X)))
(HIGH-DIGIT (BNDS-REF X N))) (IPLUS (INTEGERLENGTH HIGH-DIGIT) (ITIMES (CONSTANT BIGNUMDIGIT.LENGTH) N))))))
(INTEGERLENGTH (FIX X)))))
(PROG ((LEN (CONSTANT (LRSH (SUB1 BITS.PER.FIXP)
1)))
(BIT (CONSTANT (LLSH 1 (LRSH (SUB1 BITS.PER.FIXP)
1))))
(SHIFTER (CONSTANT (LLSH 1 (SUB1 (LRSH (SUB1 BITS.PER.FIXP)
1)))))
(ONEUP 0)) (* 'len' IS LENGTH OF FIRST TRIAL 'bit')
(* 'shifter' IS amount by which to shift the 'bit' ON
this round)
(IF (NOT (FIXP X))
THEN (SETQ X (FIX X)))
SCANBITS
(if (IGEQ X BIT)
then (if (ILESSP X (SETQ ONEUP (LSH BIT 1)))
then (* Here, we've boiled it down to between two powers of
2)
(RETURN LEN)
elseif (EQ ONEUP (CONSTANT (SUB1 BITS.PER.FIXP)))
then (* May be it was actually the higher bit)
(RETURN (CONSTANT (SUB1 BITS.PER.FIXP))))
(SETQ BIT (LLSH BIT SHIFTER))
(SETQ LEN (IPLUS LEN SHIFTER))
elseif (IGEQ X (LRSH BIT 1))
then (RETURN (SUB1 LEN))
else (SETQ BIT (LRSH BIT SHIFTER))
(SETQ LEN (IDIFFERENCE LEN SHIFTER)))
(OR (EQ SHIFTER 1)
(SETQ SHIFTER (LRSH SHIFTER 1)))
(GO SCANBITS)))))
)
(DEFINEQ
(ABS
(LAMBDA (X) (* JonL "17-Mar-84 22:24")
(COND
((FIXP X)
(COND
((ILESSP X 0)
(IDIFFERENCE 0 X))
(T X)))
((FLOATP X)
(COND
((FLESSP X 0.0)
(FDIFFERENCE 0.0 X))
(T X)))
(T (* Note that there is no "contagion" for this function,
as there is for PLUS and TIMES)
(LISPERROR "NON-NUMERIC ARG" X)))))
(DIFFERENCE
[LAMBDA (X Y) (* lmm: 17-DEC-75 23Q 65Q)
(COND
((AND (FIXP X)
(FIXP Y))
(IDIFFERENCE X Y))
(T (FDIFFERENCE X Y])
(GREATERP
[LAMBDA (X Y) (* lmm: 17-DEC-75 23Q 65Q)
(COND
((AND (FIXP X)
(FIXP Y))
(IGREATERP X Y))
(T (FGREATERP X Y])
(PLUS
(LAMBDA N (* JonL "17-Mar-84 22:17")
(* Microcode generally handles the case of two args both
FIXPs)
(PROG (R (J 0))
LP (COND
((NEQ J N)
(SETQ J (ADD1 J))
(SETQ R (COND
((AND (FIXP (ARG N J))
(NOT (FLOATP R)))
(IPLUS (OR R 0)
(ARG N J)))
(T (FPLUS (OR R 0.0)
(ARG N J)))))
(GO LP)))
(RETURN R))))
(QUOTIENT
[LAMBDA (X Y) (* lmm: 17-DEC-75 25Q 36Q)
(COND
((AND (FIXP X)
(FIXP Y))
(IQUOTIENT X Y))
(T (FQUOTIENT X Y])
(REMAINDER
[LAMBDA (X Y) (* lmm: 17-DEC-75 25Q 36Q)
(COND
((AND (FIXP X)
(FIXP Y))
(IREMAINDER X Y))
(T (FREMAINDER X Y])
(LESSP
[LAMBDA (X Y) (* lmm: 17-DEC-75 23Q 73Q)
(COND
((AND (FIXP Y)
(FIXP X))
(IGREATERP Y X))
(T (FGREATERP Y X])
(MINUS
(LAMBDA (X) (* JonL "17-Mar-84 22:21")
(COND
((FIXP X)
(IDIFFERENCE 0 X))
(T (FDIFFERENCE 0.0 X)))))
(TIMES
(LAMBDA N (* JonL "17-Mar-84 22:22")
(PROG (R (J 0))
LP (COND
((NEQ J N)
(SETQ J (ADD1 J))
(SETQ R (COND
((AND (FIXP (ARG N J))
(NOT (FLOATP R)))
(ITIMES (OR R 1)
(ARG N J)))
(T (FTIMES (OR R 1.0)
(ARG N J)))))
(GO LP)))
(RETURN R))))
)
(DEFINEQ
(FMINUS
[LAMBDA (X) (* lmm " 5-MAR-80 23:12")
(FDIFFERENCE 0.0 X])
(FREMAINDER
[LAMBDA (X Y) (* rrb "24-APR-80 10:37")
(FDIFFERENCE X (FTIMES (FLOAT (FIX (FQUOTIENT X Y)))
Y])
)
(DEFINEQ
(RANDSET
[LAMBDA (X) (* lmm "22-APR-80 11:03")
(PROG (RS RS1 RS2)
(COND
((NULL X)
(GO OUT))
((EQ X T) (* initialize with clock)
(SETQ RS1 (CLOCK))
(SETQ RS2 (IDATE)))
((AND (FIXP (CDR (LISTP X)))
(FIXP (CAR X)))
(* user supplies initialization, old-style)
(SETQ RS1 (CAR X))
(SETQ RS2 (CDR X)))
((AND (EQ (LENGTH X)
67Q)
(EVERY X (FUNCTION FIXP)))
[SETQ RS (MAPCAR X (FUNCTION (LAMBDA (N)
(IPLUS N]
(GO XX))
(T (ERROR (QUOTE "ARG NOT PREVIOUS VALUE OF RANDSET")
X)))
[SETQ RS
(MAPCAR (QUOTE (150177Q 134506Q 2372Q 154626Q 170230Q 66113Q 25744Q 40670Q 105776Q
171521Q 26405Q 111676Q 103564Q 151Q 162576Q 66157Q 23404Q 10171Q
157167Q 73124Q 57746Q 2565Q 152474Q 151770Q 124444Q 7426Q 114136Q
26172Q 146043Q 2037Q 1673Q 37700Q 46706Q 162146Q 6277Q 176221Q
3250Q 41735Q 156764Q 41547Q 144665Q 135532Q 63240Q 10560Q 5504Q
145075Q 114776Q 176503Q 160605Q 104147Q 12303Q 27516Q 35414Q
23625Q 25100Q))
(FUNCTION (LAMBDA (Z)
(LOGAND [IPLUS Z (SETQ RS2 (PROG1 (IPLUS (ITIMES RS1 46635Q)
RS1)
(SETQ RS1 RS2]
177777Q]
XX (FRPLACD (LAST RS)
RS)
(SETQ RANDSTATE (CONS RS (FNTH RS 37Q)))
OUT (RETURN (for X in (CAR RANDSTATE) as I from 1 to 67Q collect X])
(RAND
[LAMBDA (LOWER UPPER) (* edited: "29-Mar-84 15:49")
(* This function implements the XRAND subroutine described in Stanford memo STAN-CS-77-601, Analysis of Additive
Random Number Generators, by John F. Reiser, on p 28.0 Rather than storing the X values in an array and computing
indexes I and J, however, I have elected to retain state in a circular list of 63Q elements.
RANDSTATE is (CONS X (NTH X 37Q)); each time RAND is called, both CAR and CDR of RANDSTATE are CDR'ed to
effectively increment the index. In addition, the numbers are stored as 20Q bit binary fractions
(i.e. the decimal point is on the left of the 16-bit quantity))
(PROG (I J)
(OR (LISTP RANDSTATE)
(PROGN (RANDSET T)
RANDSTATE))
(SETQ I (CDAR RANDSTATE))
(SETQ J (CDDR RANDSTATE))
(RPLNODE RANDSTATE I J)
(RPLACA I (LOGAND (IDIFFERENCE (CAR I)
(CAR J))
MAX.SMALLP)))
(COND
[(NOT UPPER)
(COND
((NULL LOWER) (* both UPPER and LOWER nil. Return number
(0 .. MAX.SMALLP) -
not documented)
(CAAR RANDSTATE))
((FIXP LOWER) (* (RAND n) = (RAND 0 n-1))
(IREMAINDER (CAAR RANDSTATE)
LOWER))
(T (* (RAND N) N floating. Return
(RAND 0 N))
(FTIMES LOWER (FQUOTIENT (CAAR RANDSTATE)
(CONSTANT (FLOAT (ADD1 MAX.SMALLP]
[(AND (FIXP LOWER)
(FIXP UPPER))
(OR (IGREATERP UPPER LOWER)
(swap UPPER LOWER))
(SETQ UPPER (IDIFFERENCE UPPER LOWER))
(COND
((IGREATERP UPPER MAX.SMALLP)
(IPLUS (IMOD (\MAKENUMBER (CAAR RANDSTATE)
(CADAR RANDSTATE))
(ADD1 UPPER))
LOWER))
(T (IPLUS (IREMAINDER (CAAR RANDSTATE)
(ADD1 UPPER))
LOWER]
(T (FPLUS [FTIMES (FDIFFERENCE UPPER LOWER)
(FQUOTIENT (CAAR RANDSTATE)
(CONSTANT (FLOAT (ADD1 MAX.SMALLP]
LOWER])
(SQRT
(LAMBDA (N) (* JonL "25-Jan-84 19:28")
(PROG ((X (OR (FLOATP N)
(FLOAT N)))
V)
(if (FGREATERP 0.0 X)
then (ERROR "SQRT OF NEGATIVE VALUE" N)
elseif (NOT (FGREATERP X 0.0))
then (* Trichotomy ==> X = 0.0)
(RETURN 0.0))
(SETQ V (create FLOATP
EXPONENT ←(LOADBYTE (IPLUS 200Q (LRSH (LOADBYTE (IDIFFERENCE
(fetch (FLOATP EXPONENT)
of X)
200Q)
0 20Q)
1))
0 10Q)
HIFRACTION ←(fetch (FLOATP HIFRACTION) of X)))
(* Exponent is stored as excess "200Q" and although the LRSH doesn't really do division by 2
(e.g., when the arg is negative) at least the low-order 10Q bits will be right. It doesn't even matter that it may
be off-by-one, due to the infamous "Arithmetic Shifting Considered Harmful" since it is only an estimate.)
(FRPTQ 4 (SETQ V (FTIMES .5 (FPLUS V (FQUOTIENT X V)))))
(RETURN V))))
(EXPT
(LAMBDA (A N) (* JonL " 7-Dec-83 02:08")
(if (FIXP N)
then (if (FIXP A)
then (IEXPT A N)
elseif (FEQP 0.0 (SETQ A (FLOAT A)))
then (if (ZEROP N)
then 1.0
else 0.0)
else (PROG ((V 1.0))
(if (ILESSP N 0)
then (SETQ A (FQUOTIENT 1.0 A))
(SETQ N (IMINUS N)))
LP (if (ODDP N)
then (SETQ V (TIMES A V)))
(if (ZEROP (SETQ N (LRSH N 1)))
then (RETURN V))
(SETQ A (TIMES A A))
(GO LP)))
else (FEXPT A N))))
(IEXPT
(LAMBDA (A N) (* JonL " 7-Dec-83 01:38")
(* Integer EXPonentiation -- works by clever
bit-dissection method)
(SETQ A (FIX A))
(if (NOT (IGREATERP (SETQ N (FIX N))
0))
then (if (ZEROP N)
then 1
else (FIX (FEXPT A N)))
elseif (ZEROP A)
then 0
else (PROG ((V 1))
LP (if (ODDP N)
then (SETQ V (TIMES A V)))
(if (ZEROP (SETQ N (LRSH N 1)))
then (RETURN V))
(SETQ A (TIMES A A))
(GO LP)))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ RANDSTATE NIL)
(RPAQQ \TOL 9.999992E-6)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS RANDSTATE \TOL)
)
(* ugly hacks)
(DEFINEQ
(PutUnboxed
(LAMBDA (PTR NUM) (* JonL "25-JUL-83 02:29")
(\PUTFIXP PTR NUM)))
(\PUTFIXP
[LAMBDA (PTR NUM) (* lmm "11-DEC-80 15:10")
(PROG (HI LO)
(.UNBOX. NUM HI LO)
(replace (FIXP HINUM) of PTR with HI)
(replace (FIXP LONUM) of PTR with LO)
(RETURN NUM])
(\PUTSWAPPEDFIXP
[LAMBDA (PTR NUM) (* edited: " 7-JUN-83 10:34")
(* store in MESA order rather than LISP order)
(PROG (HI LO)
(.UNBOX. NUM HI LO)
(replace (FIXP LONUM) of PTR with HI)
(replace (FIXP HINUM) of PTR with LO)
(RETURN NUM])
(\HINUM
[LAMBDA (NUM) (* lmm "12-APR-81 22:01")
(PROG (HI LO)
(.UNBOX. NUM HI LO)
(RETURN HI])
(\LONUM
[LAMBDA (NUM) (* lmm "12-APR-81 22:02")
(PROG (HI LO)
(.UNBOX. NUM HI LO)
(RETURN LO])
(TRUNCATEMULTIPLY
[LAMBDA (X Y) (* lmm "13-OCT-80 12:19")
(* this is a dreadful kludge. -
do unsigned multiply mod 32)
(COND
((ZEROP Y)
0)
[(EQ (LOGAND Y 1)
1)
(IPLUS X (TRUNCATEMULTIPLY (LLSH X 1)
(LRSH Y 1]
(T (TRUNCATEMULTIPLY (LLSH X 1)
(LRSH Y 1])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS PutUnboxed DMACRO (= . \PUTFIXP))
)
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA TIMES PLUS LOGXOR LOGOR LOGAND ITIMES IPLUS)
)
(PUTPROPS LLARITH COPYRIGHT ("Xerox Corporation" 3676Q 3677Q 3700Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4433Q 5332Q (IDIFFERENCE 4445Q . 4666Q) (IGREATERP 4670Q . 5111Q) (IQUOTIENT 5113Q .
5330Q)) (5333Q 24752Q (\SLOWIPLUS2 5345Q . 10167Q) (\SLOWIDIFFERENCE 10171Q . 13657Q) (\SLOWIGREATERP
13661Q . 14357Q) (\SLOWLLSH1 14361Q . 15143Q) (\SLOWLLSH8 15145Q . 15655Q) (\SLOWLOGAND2 15657Q .
16277Q) (\SLOWLOGOR2 16301Q . 16716Q) (\SLOWLOGXOR2 16720Q . 17340Q) (\SLOWLRSH1 17342Q . 20042Q) (
\SLOWLRSH8 20044Q . 20520Q) (\SLOWITIMES2 20522Q . 24526Q) (\SLOWIQUOTIENT 24530Q . 24750Q)) (25064Q
27172Q (\BOXIPLUS 25076Q . 25325Q) (\BOXIDIFFERENCE 25327Q . 27170Q)) (27224Q 30305Q (\MAKENUMBER
27236Q . 30303Q)) (30306Q 30604Q (OVERFLOW 30320Q . 30602Q)) (36515Q 52432Q (EQP 36527Q . 37547Q) (FIX
37551Q . 40004Q) (IQUOTIENT 40006Q . 40223Q) (IREMAINDER 40225Q . 40445Q) (LLSH 40447Q . 42033Q) (
LRSH 42035Q . 43557Q) (LSH 43561Q . 50263Q) (RSH 50265Q . 52430Q)) (62741Q 102654Q (MINUSP 62753Q .
63205Q) (ILESSP 63207Q . 63273Q) (IMINUS 63275Q . 63361Q) (IPLUS 63363Q . 64635Q) (ITIMES 64637Q .
66115Q) (LOGAND 66117Q . 67375Q) (LOGOR 67377Q . 70651Q) (LOGXOR 70653Q . 72131Q) (SUB1 72133Q .
72300Q) (ZEROP 72302Q . 72350Q) (ADD1 72352Q . 72426Q) (GCD 72430Q . 73014Q) (IEQP 73016Q . 73226Q) (
INTEGERLENGTH 73230Q . 102652Q)) (102655Q 107541Q (ABS 102667Q . 103631Q) (DIFFERENCE 103633Q .
104116Q) (GREATERP 104120Q . 104375Q) (PLUS 104377Q . 105416Q) (QUOTIENT 105420Q . 105675Q) (REMAINDER
105677Q . 106163Q) (LESSP 106165Q . 106437Q) (MINUS 106441Q . 106732Q) (TIMES 106734Q . 107537Q)) (
107542Q 110160Q (FMINUS 107554Q . 107721Q) (FREMAINDER 107723Q . 110156Q)) (110161Q 124312Q (RANDSET
110173Q . 113152Q) (RAND 113154Q . 117331Q) (SQRT 117333Q . 121523Q) (EXPT 121525Q . 123007Q) (IEXPT
123011Q . 124310Q)) (124607Q 127656Q (PutUnboxed 124621Q . 125031Q) (\PUTFIXP 125033Q . 125503Q) (
\PUTSWAPPEDFIXP 125505Q . 126350Q) (\HINUM 126352Q . 126575Q) (\LONUM 126577Q . 127022Q) (
TRUNCATEMULTIPLY 127024Q . 127654Q)))))
STOP