(FILECREATED " 7-Mar-85 16:52:54" {ERIS}<LISPCORE>SOURCES>LLFLOAT.;29 70775
changes to: (FNS \UNBOXFLOAT2)
previous date: " 7-Mar-85 10:18:24" {ERIS}<LISPCORE>SOURCES>LLFLOAT.;28)
(* Copyright (c) 1982, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLFLOATCOMS)
(RPAQQ LLFLOATCOMS [(DECLARE: DONTCOPY (MACROS \HAND.FLOATUNBOX)
(EXPORT (MACROS POLYEVAL)))
(COMS (FNS \PUTBASEFLOATP \GETBASEFLOATP)
(MACROS \PUTBASEFLOATP \GETBASEFLOATP (* " the following deal with raw 32 bit numbers")
\.PUTBASE32 \.GETBASE32))
[COMS (FNS FTIMES FPLUS FQUOTIENT FDIFFERENCE FGREATERP FABS)
(* UFNs)
(FNS \SLOWFDIFFERENCE \SLOWFPLUS2 \SLOWFTIMES2 \SLOWFQUOTIENT \SLOWFGREATERP)
(FNS \FZEROP FEQP FLOAT \FLOAT \FIXP.FROM.FLOATP FIXR \BOXFPLUSDIF \BOXFQUOTIENT
\BOXFTIMES2 \INFINITY \MAKEFLOAT MAKEFLOATNUMBER PutFloat \FZEROP MAKERATIONAL)
(PROP DMACRO ZEROP)
(FNS SQRT)
(DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS FLOATP)
(CONSTANTS (MAX.DIGITS.ACCURACY 9)))
(CONSTANTS (\8BITS 255)
(\MAX.HI.FRAC 127)
(\SIGNBIT 32768)
(\EXPONENT.BIAS 127)
(\HIDDENBIT 128)
(\MAX.EXPONENT 255))
(MACROS .FLOATUNBOX. .LLSH1. .LLSH8. .LRSH1. .LRSH8. .LRSHSTICKY. .ADDSMALL2.
.ADDSMALL3. .SUBSMALL. .POWEROF2.)
(LOCALVARS . T))
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\UNDERFLOW)
(MAX.FLOAT (\INFINITY 0))
(MIN.FLOAT (\INFINITY 1)))
(P (MOVD? (QUOTE FGREATERP)
(QUOTE FGTP]
[COMS (* * "unboxed ufns")
(FNS \UNBOXFLOAT1 \UNBOXFLOAT2 \UNBOXFLOAT3)
(* unboxed arg handling)
(DECLARE: DONTCOPY (EXPORT (MACROS \CALLER.ARGS]
[COMS (* * "matrix multiplication")
(FNS MATMULT MATMULT444 MATMULT133 MATMULT331 MATMULT333 MATMULT144 MATMULT441)
(FNS \MATMULT GETELT SETELT \GETELT \SETELT)
(DECLARE: DONTCOPY (EXPORT (MACROS \GETELT GETELT \SETELT SETELT))
(EXPORT (MACROS MATMULT444 MATMULT133 MATMULT331 MATMULT333 MATMULT144
MATMULT441))
(EXPORT (MACROS .MATMULT444 .MATMULT133 .MATMULT331 .MATMULT333 .MATMULT144
.MATMULT441]
[COMS (FNS \FLOATINGSCALE \INIT.POWERS.OF.TEN \CONVERT.FLOATING.NUMBER \PRODUCE.FDIGIT)
(DECLARE: DONTCOPY (GLOBALVARS \POWERS.OF.TEN)
(MACROS \POWER.OF.TEN))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\INIT.POWERS.OF.TEN]
(COMS (FNS FLOATP.TO.BCPL BCPL.TO.FLOATP)
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS BCPLNUM)))
(PROP ARGNAMES \UNBOXFLOAT1 \UNBOXFLOAT2 \UNBOXFLOAT3)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA FPLUS FTIMES])
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \HAND.FLOATUNBOX MACRO [LAMBDA (X)
(* this doesn't call \FLOATUNBOX because it's used by the UFN case of \FLOATUNBOX. -
takes a FLOATP and returns the raw unboxed bits of the value. Must be used with great caution as raw unboxed bits
are not allowed in many places.)
(\VAG2 (fetch (FLOATP HIWORD) of (SETQ X (FLOAT X)))
(fetch (FLOATP LOWORD) of X])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS POLYEVAL DMACRO ((X COEFFS DEGREE)
(* execute the POLYEVAL opcode on the value X, the array COEFFS with
degree DEGREE)
(\FLOATBOX ((OPCODES UBFLOAT3 0)
(\FLOATUNBOX X)
(fetch (ARRAYP BASE)
of COEFFS)
DEGREE))))
)
(* END EXPORTED DEFINITIONS)
)
(DEFINEQ
(\PUTBASEFLOATP
[LAMBDA (BASE OFFST VAL) (* JonL " 7-FEB-83 19:42")
(\MACRO.MX (\PUTBASEFLOATP BASE OFFST VAL))])
(\GETBASEFLOATP
[LAMBDA (BASE OFFST) (* JonL " 7-FEB-83 19:41")
(\MACRO.MX (\GETBASEFLOATP BASE OFFST))])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \PUTBASEFLOATP DMACRO [(BASE OFFST VAL)
(* put the floatp VAL at offset OFFST from BASE. Used by
REPLACEFIELD of floatp fields)
(\FLOATBOX (\.PUTBASE32 BASE OFFST (\FLOATUNBOX VAL])
(PUTPROPS \GETBASEFLOATP DMACRO ((BASE OFFST)
(* get the floatp at OFFST from BASE)
(\FLOATBOX (\.GETBASE32 BASE OFFST))))
(PUTPROPS \.PUTBASE32 DMACRO (= . \PUTBASEPTR))
(PUTPROPS \.GETBASE32 DMACRO (APPLY* COMP.GETBASE NIL GETBASE.32))
)
(DEFINEQ
(FTIMES
(LAMBDA N (* JonL "17-May-84 18:35")
(PROG (R (J 1))
(COND
((EQ 0 N)
(RETURN 1.0))
((EQ N 1)
(RETURN (FLOAT (ARG N 1)))))
(SETQ R (ARG N 1))
LP (COND
((NEQ J N)
(SETQ J (ADD1 J)) (* assumes that FTIMES compiles into opcode that punts
into \FTIMES.UFN)
(SETQ R (FTIMES R (ARG N J)))
(GO LP)))
(RETURN R))))
(FPLUS
(LAMBDA N (* JonL "17-May-84 18:35")
(PROG (R (J 1))
(COND
((EQ 0 N)
(RETURN 0.0))
((EQ N 1)
(RETURN (FLOAT (ARG N 1)))))
(SETQ R (ARG N 1))
LP (COND
((NEQ J N)
(SETQ J (ADD1 J))
(SETQ R (FPLUS R (ARG N J)))
(GO LP)))
(RETURN R))))
(FQUOTIENT
[LAMBDA (X Y) (* lmm "11-FEB-82 14:02")
((OPCODES FQUOTIENT)
X Y])
(FDIFFERENCE
[LAMBDA (X Y) (* lmm "14-MAR-84 22:20")
((OPCODES FDIFFERENCE)
X Y])
(FGREATERP
[LAMBDA (X Y) (* lmm "17-Oct-84 15:45")
(* to compare two floats, compare signbits, and if they
are equal compare the remaining 31 bits of each number
as unsigned integers)
((OPCODES FGREATERP)
X Y])
(FABS
[LAMBDA (X)
(\MACRO.MX (FABS X))])
)
(* UFNs)
(DEFINEQ
(\SLOWFDIFFERENCE
[LAMBDA (X Y) (* lmm "17-Oct-84 15:42")
(\CALLME (QUOTE FDIFFERENCE))
(\BOXFPLUSDIF X Y T])
(\SLOWFPLUS2
[LAMBDA (X Y) (* lmm "17-Oct-84 15:42")
(* UFN for FPLUS)
(\CALLME (QUOTE FPLUS))
(\BOXFPLUSDIF X Y])
(\SLOWFTIMES2
[LAMBDA (X Y) (* lmm "17-Oct-84 15:43")
(\CALLME (QUOTE FTIMES))
(\BOXFTIMES2 X Y])
(\SLOWFQUOTIENT
[LAMBDA (X Y) (* lmm "17-Oct-84 15:43")
(\CALLME (QUOTE FQUOTIENT)) (* UFN for FQUOTIENT)
(\BOXFQUOTIENT X Y NIL])
(\SLOWFGREATERP
[LAMBDA (X Y) (* JonL "17-May-84 18:34")
(* to compare two floats, compare signbits, and if they
are equal compare the remaining 31 bits of each number
as unsigned integers)
(COND
[(AND (FLOATP X)
(FLOATP Y)) (* Can speed this up by not unpacking--check signs,
then compare remaining 31d bits as unsigned numbers)
(PROG ((HX (fetch (FLOATP HIWORD) of X))
(HY (fetch (FLOATP HIWORD) of Y))
SIGNX)
(RETURN (COND
((NEQ (SETQ SIGNX (LOGAND HX \SIGNBIT))
(LOGAND HY \SIGNBIT))
(EQ 0 SIGNX))
[(EQ 0 SIGNX) (* numbers are positive)
(OR (IGREATERP HX HY)
(AND (EQ HX HY)
(IGREATERP (fetch LOWORD of X)
(fetch LOWORD of Y]
(T (* Numbers are negative, so compare in other direction)
(OR (IGREATERP HY HX)
(AND (EQ HX HY)
(IGREATERP (fetch LOWORD of Y)
(fetch LOWORD of X]
(T (PROG (HX LX SIGNX EXPX HY LY SIGNY EXPY)
(.FLOATUNBOX. X SIGNX EXPX HX LX)
(.FLOATUNBOX. Y SIGNY EXPY HY LY)
(RETURN (COND
((NEQ SIGNX SIGNY)
(EQ 0 SIGNX))
[(EQ 0 SIGNX) (* numbers are positive)
(OR (IGREATERP EXPX EXPY)
(AND (EQ EXPX EXPY)
(OR (IGREATERP HX HY)
(AND (EQ HX HY)
(IGREATERP LX LY]
(T (* Numbers are negative, so compare in other direction)
(OR (IGREATERP EXPY EXPX)
(AND (EQ EXPY EXPX)
(OR (IGREATERP HY HX)
(AND (EQ HY HX)
(IGREATERP LY LX])
)
(DEFINEQ
(\FZEROP
(LAMBDA (X) (* JonL "27-Sep-84 22:20")
(* Support for generic ZEROP macro)
(AND (EQ 0 (fetch LOWORD of (\DTEST X (QUOTE FLOATP))))
(EQ 0 (fetch HIWORDNOSIGNBIT of X)))))
(FEQP
(LAMBDA (X Y) (* JonL "17-May-84 20:26")
(COND
((AND (FLOATP X)
(FLOATP Y)) (* If they're both floatp already, can essentially
compare contents, since floatps are generally
normalized.)
(* Last OR clause is to check for comparing a negative
zero to a positive zero.)
(AND (EQ (fetch LOWORD of X)
(fetch LOWORD of Y))
(OR (EQ (fetch HIWORD of X)
(fetch HIWORD of Y))
(AND (EQ 0 (fetch HIWORDNOSIGNBIT of X))
(EQ 0 (fetch HIWORDNOSIGNBIT of Y))))))
(T (PROG (SIGNX EXPX HX LX SIGNY EXPY HY LY)
(.FLOATUNBOX. X SIGNX EXPX HX LX T)
(.FLOATUNBOX. Y SIGNY EXPY HY LY T)
(RETURN (AND (EQ HX HY)
(EQ LX LY)
(EQ EXPX EXPY)
(OR (EQ SIGNX SIGNY)
(AND (EQ 0 EXPX)
(EQ 0 HX)
(EQ 0 LX))))))))))
(FLOAT
[LAMBDA (X) (* lmm "28-Jun-84 14:58")
(* compiles this way, too)
(\DTEST X (QUOTE FLOATP])
(\FLOAT
[LAMBDA (X) (* JonL "17-May-84 18:34")
(OR (FLOATP X)
(PROG (HI LO (SIGN 0))
RETRY
(SELECTC (NTYPX X)
[\FIXP (SETQ HI (fetch (FIXP HINUM) of X))
(SETQ LO (fetch (FIXP LONUM) of X))
(COND
((IGREATERP HI MAX.POS.HINUM)
(.NEGATE. HI LO)
(SETQ SIGN 1]
[\SMALLP (SETQ HI 0)
(SETQ LO (COND
((SMALLPOSP X)
X)
(T (SETQ SIGN 1) (* X is negative--negate it)
(COND
((EQ 0 (LOLOC X)) (* Min small integer)
(SETQ HI 1)
0)
(T (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (LOLOC X]
(PROGN (SETQ X (LISPERROR "NON-NUMERIC ARG" X T))
(GO RETRY)))
(RETURN (\MAKEFLOAT SIGN (IPLUS \EXPONENT.BIAS 37Q)
HI LO T])
(\FIXP.FROM.FLOATP
(LAMBDA (X) (* JonL "17-May-84 18:36")
(PROG (SIGN EXP HI LO)
(.FLOATUNBOX. X SIGN EXP HI LO (GO RETZERO))
(SETQ EXP (IDIFFERENCE EXP (SUB1 \EXPONENT.BIAS)))
(* number of bits to left of binary point)
(COND
((ILESSP EXP 0)
(RETURN 0))
((OR (IGREATERP EXP 32)
(AND (EQ EXP 32)
(OR (EQ 0 SIGN)
(NEQ HI \SIGNBIT)
(NEQ LO 0)))) (* Overflow: number is larger than MAX.INTEGER)
(SELECTQ \OVERFLOW
(T (RETURN (LISPERROR "OVERFLOW" X T)))
(RETURN (COND
((EQ 0 SIGN)
MAX.INTEGER)
(T MIN.INTEGER))))))
(COND
((IGEQ (SETQ EXP (IDIFFERENCE 32 EXP))
16)
(SETQ LO (LRSH HI (IDIFFERENCE EXP 16)))
(SETQ HI 0))
(T (* large integer, have to manipulate both halves)
(FRPTQ EXP (.LRSH1. HI LO))))
(COND
((EQ SIGN 1)
(.NEGATE. HI LO)))
(RETURN (\MAKENUMBER HI LO))
RETZERO
(RETURN 0))))
(FIXR
(LAMBDA (X) (* JonL "17-May-84 18:40")
(OR (FIXP X)
(PROG (SIGN EXP HI LO ROUNDINGBITS)
(.FLOATUNBOX. X SIGN EXP HI LO (GO RETZERO))
(SETQ EXP (IDIFFERENCE EXP (SUB1 \EXPONENT.BIAS)))
(* number of bits to left of binary point)
(COND
((ILESSP EXP 0)
(RETURN 0))
((OR (IGREATERP EXP 32)
(AND (EQ EXP 32)
(OR (EQ 0 SIGN)
(NEQ HI \SIGNBIT)
(NEQ LO 0)))) (* Overflow: number is larger than MAX.FIXP)
(RETURN (SELECTQ \OVERFLOW
(T (LISPERROR "OVERFLOW" X T))
(COND
((EQ 0 SIGN)
MAX.FIXP)
(T MIN.FIXP))))))
(COND
((IGEQ EXP 24) (* No decimal places to worry about, so no rounding,
just shift into place)
(FRPTQ (IDIFFERENCE 32 EXP)
(.LRSH1. HI LO)))
(T
(* Shift right until binary point is in the middle of LO, as per \MAKEFLOAT; then decide how to round, and shift
right once more)
(COND
((IGEQ (SETQ EXP (IDIFFERENCE 24 EXP))
16) (* shifting all the way out of the high word)
(SETQ LO (LRSH (LOGOR HI (COND
((EQ 0 LO)
0)
(T (* Sticky bits)
(LRSH \8BITS 1))))
(IDIFFERENCE EXP 16)))
(SETQ HI 0))
(T (* Shift both halves, keeping sticky bits in LO)
(FRPTQ EXP (.LRSHSTICKY. HI LO))))
(SETQ ROUNDINGBITS (LOGAND LO \8BITS))
(.LRSH8. HI LO) (* Shift the rest of the way)
(COND
((OR (IGREATERP ROUNDINGBITS 128)
(AND (EQ ROUNDINGBITS 128)
(ODDP LO))) (* Round up if greater than .5, or exactly .5 and
rounding up will make number even)
(COND
((EQ LO MAX.SMALL.INTEGER)
(SETQ LO 0)
(add HI 1))
(T (add LO 1)))))))
(COND
((EQ SIGN 1)
(.NEGATE. HI LO)))
(RETURN (\MAKENUMBER HI LO))
RETZERO
(RETURN 0)))))
(\BOXFPLUSDIF
(LAMBDA (X Y SUBTRACT BOX) (* JonL "17-May-84 18:56")
(* Does X-Y if SUBTRACT is true)
(PROG (SIGNX EXPX HX LX SIGNY EXPY HY LY EXPDIFF PLEASENORMALIZE CARRY)
(.FLOATUNBOX. Y SIGNY EXPY HY LY)
(COND
(SUBTRACT (SETQ SIGNY (IDIFFERENCE 1 SIGNY))))
(.FLOATUNBOX. X SIGNX EXPX HX LX (GO RESULTISY))
(COND
((AND (EQ 0 HY)
(EQ 0 LY))
(GO DONE))
((EQ EXPX \MAX.EXPONENT) (* X = infinity, so result is infinity.
This is not quite right if Y is infinity of opposite
sign, though)
(RETURN (\INFINITY SIGNX BOX)))
((EQ EXPY \MAX.EXPONENT)
(RETURN (\INFINITY SIGNY BOX))))
(SETQ EXPDIFF (IDIFFERENCE EXPX EXPY)) (* first align the binary points by right-shifting the
smaller guy)
(COND
((IGREATERP EXPDIFF 0)
(COND
((IGREATERP EXPDIFF 31) (* Y would get shifted into oblivion)
(GO DONE))
(T (FRPTQ EXPDIFF (.LRSHSTICKY. HY LY)))))
((NEQ EXPDIFF 0)
(COND
((ILESSP EXPDIFF -31)
(GO RESULTISY))
(T (FRPTQ (IMINUS EXPDIFF)
(.LRSHSTICKY. HX LX))
(SETQ EXPX EXPY)))))
(COND
((EQ SIGNX SIGNY) (* same sign, add magnitudes)
(SETQ CARRY (.ADDSMALL2. LX LY))
(COND
((EQ (.ADDSMALL3. HX HY CARRY)
1) (* there was a carry out of HX, so shift everyone right
and stick it back in)
(.LRSHSTICKY. HX LX)
(add HX \SIGNBIT)
(add EXPX 1))))
(T (* subtract magnitudes, smaller from larger)
(COND
((OR (ILESSP HX HY)
(AND (EQ HX HY)
(ILESSP LX LY))) (* Y is bigger, so swap)
(swap HX HY)
(swap LX LY)
(SETQ SIGNX SIGNY)))
(SETQ PLEASENORMALIZE (NEQ (LOGAND HX \SIGNBIT)
0)) (* thus if neither operand is normalized, we won't waste
time normalizing and denormalizing the result)
(SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY)
(.SUBSMALL. LX LY)))))
DONE(RETURN (\MAKEFLOAT SIGNX EXPX HX LX PLEASENORMALIZE BOX))
RESULTISY
(RETURN (\MAKEFLOAT SIGNY EXPY HY LY NIL BOX)))))
(\BOXFQUOTIENT
[LAMBDA (X Y BOX) (* lmm "18-DEC-80 13:40")
(PROG (SIGNX EXPX HX LX (SIGNY 0)
(EXPY 0)
HY LY BORROW (HZ 0)
(LZ 0))
(.FLOATUNBOX. X SIGNX EXPX HX LX (GO DONE))
(.FLOATUNBOX. Y SIGNY EXPY HY LY (GO DIVZERO))
(COND
((EQ EXPX \MAX.EXPONENT)
(* X is infinity)
(RETURN (\INFINITY SIGNX BOX)))
((EQ EXPY \MAX.EXPONENT)
(* Y = infinity, result is zero)
(GO DONE)))
(* * Divide X -- double length, implicitly extended with zeros -- by Y. At each step, Y is subtracted from X if
possible, putting a one bit in the quotient, and then X and the quotient are shifted left. Result is a 32-bit
quotient.)
(.LRSH1. HX LX)
(.LRSH1. HY LY) (* shift these right one so that we never have to worry about carrying out of the
high bit)
(FRPTQ 31 (PROGN (.LLSH1. HZ LZ)
(* shift quotient left one as we accumulate it)
(COND
((OR (AND (EQ HX HY)
(IGEQ LX LY))
(IGREATERP HX HY))
(* X GE Y, so subtract Y)
(SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY)
(.SUBSMALL. LX LY)))
(SETQ LZ (ADD1 LZ))
(* note that this never overflows, because of the left shift we did above)
))
(* now shift dividend left one. After the subtraction the high-order bit must be
off, so this works okay)
(.LLSH1. HX LX)))
(.LLSH1. HZ LZ) (* left shift result 1 to compensate for the earlier right shifts)
[COND
((OR (NEQ HX 0)
(NEQ LX 0)) (* set sticky bit)
(SETQ LZ (LOGOR LZ 1]
DONE(RETURN (\MAKEFLOAT (LOGXOR SIGNX SIGNY)
(IPLUS (IDIFFERENCE EXPX EXPY)
\EXPONENT.BIAS)
HZ LZ T BOX))
DIVZERO
(RETURN (COND
((EQ \OVERFLOW T)
(ERROR "FLOATING DIVIDE BY ZERO" Y))
(T (\INFINITY SIGNX BOX])
(\BOXFTIMES2
(LAMBDA (X Y BOX) (* JonL "17-May-84 18:56")
(PROG (SIGNX EXPX HX LX (SIGNY 0)
(EXPY 0)
HY LY (HHY 0)
(HHZ 0)
(HZ 0)
(LZ 0)
SAVEHY SAVELY CARRY)
(.FLOATUNBOX. X SIGNX EXPX HX LX (GO DONE)
T)
(.FLOATUNBOX. Y SIGNY EXPY HY LY (GO DONE)
T)
(COND
((EQ EXPX \MAX.EXPONENT) (* X = infinity)
(RETURN (\INFINITY SIGNX BOX)))
((EQ EXPY \MAX.EXPONENT)
(RETURN (\INFINITY SIGNY BOX))))
(* * Multiply the significands. We have two 24-bit integers, so have a 48-bit, 3-word product, stored as
{HHZ,HZ,LZ}. Multiplication will be in two steps: multiply LX by {HY,LY}, storing in result, and then multiply HX
by {HY,LY}, storing in the top two words. The first multiplication can be omitted in the not uncommon case of a
zero low fraction, and the second multiplication is a little bit simpler, since result fits in two words.)
(COND
((EQ 0 LX)
(GO LP2))
((EQ 0 LY) (* swap operands to make life easier)
(swap HX HY)
(swap LX LY)
(GO LP2)))
(SETQ SAVEHY HY) (* we'll need these for second step)
(SETQ SAVELY LY)
LP1 (* multiply LX times HY,LY)
(COND
((NEQ (LOGAND LX 1)
0)
(SETQ CARRY (.ADDSMALL2. LZ LY))
(SETQ CARRY (.ADDSMALL3. HZ HY CARRY))
(SETQ HHZ (IPLUS HHZ HHY CARRY))))
(COND
((EQ 0 (SETQ LX (LRSH LX 1))) (* done with this step)
(SETQ HY SAVEHY)
(SETQ LY SAVELY)
(GO LP2)))
(SETQ HHY (LLSH HHY 1)) (* left shift Y by one)
(SETQ HY (LLSH (COND
((IGREATERP HY MAX.POS.HINUM)
(add HHY 1)
(LOGAND HY MAX.POS.HINUM))
(T HY))
1))
(SETQ LY (LLSH (COND
((IGREATERP LY MAX.POS.HINUM)
(add HY 1)
(LOGAND LY MAX.POS.HINUM))
(T LY))
1))
(GO LP1)
LP2
(* multiply HX times HY,LY, adding into high two words of Z. No overflow here, since HX has at most
(and usually exactly) 8 bits)
(COND
((NEQ (LOGAND HX 1)
0)
(SETQ CARRY (.ADDSMALL2. HZ LY))
(SETQ HHZ (IPLUS HHZ HY CARRY))))
(COND
((NEQ (SETQ HX (LRSH HX 1))
0)
(.LLSH1. HY LY)
(GO LP2)))
DONE
(* * We now have a 48-bit result in HHZ,HZ,LZ. \MAKEFLOAT can handle it from here. Note that the exponent we give
is bumped by 1, because the "binary point", which was between the first and second bits, was moved one to the
right by multiplying)
(RETURN (\MAKEFLOAT (LOGXOR SIGNX SIGNY)
(IPLUS EXPX EXPY (IDIFFERENCE 1 \EXPONENT.BIAS))
HHZ HZ T BOX)))))
(\INFINITY
[LAMBDA (SIGN BOX) (* lmm "17-DEC-80 20:32")
(* Returns "infinity" of the appropriate SIGN
(0 or 1), reusing floating BOX if given)
(* * For now, don't return true infinity, but rather the largest representable finite number, so that miscellaneous
floating-point routines don't die)
(OR (FLOATP BOX)
(SETQ BOX (create FLOATP)))
(replace (FLOATP SIGNBIT) of BOX with SIGN)
(replace (FLOATP EXPONENT) of BOX with (SUB1 \MAX.EXPONENT))
(replace (FLOATP HIFRACTION) of BOX with \MAX.HI.FRAC)
(replace (FLOATP LOFRACTION) of BOX with 65535)
BOX])
(\MAKEFLOAT
(LAMBDA (SIGN EXP HI LO NORMALIZE BOX) (* JonL "17-May-84 18:56")
(* * packs up the pieces of a floating point result into a single number box, n the process checking for
underflow, rounding, checking overflow. BOX is optional box to reuse. NORMALIZE is true if we should normalize the
result first (make sign bit of HI 1); otherwise we assume result is already normalized)
(PROG (ROUNDINGBITS)
(OR (FLOATP BOX)
(SETQ BOX (create FLOATP)))
TOP (COND
((AND (EQ 0 HI)
(EQ 0 LO))
(replace HIWORD of BOX with (replace LOWORD of BOX with 0))
(RETURN BOX)))
(COND
(NORMALIZE (COND
((EQ 0 HI)
(SETQ HI LO)
(SETQ LO 0)
(SETQ EXP (IDIFFERENCE EXP 16))))
(while (EQ 0 (LOGAND HI \SIGNBIT))
do (.LLSH1. HI LO)
(SETQ EXP (SUB1 EXP)))))
(COND
((ILEQ EXP 0) (* underflow. Scale by 2↑\Exponentbias in order to
deliver a useful value to the error handler)
(SELECTQ \UNDERFLOW
(T (RETURN (LISPERROR "FLOATING UNDERFLOW" (\MAKEFLOAT SIGN (IPLUS EXP
\EXPONENT.BIAS)
HI LO NIL BOX)
T)))
NIL) (* If we have to return a result, we must "denormalize"
this number. This gives us a little more time before
vanishing to zero)
(COND
((ILESSP EXP -24) (* too small even as denormalized number)
(SETQ HI (SETQ LO 0))
(GO TOP))
(T (* denormalize by shifting right until the exponent is
logically 1; final result will have exponent zero,
hidden bit zero)
(FRPTQ (IDIFFERENCE 1 EXP)
(.LRSHSTICKY. HI LO))
(SETQ EXP 0)))))
(SETQ ROUNDINGBITS (LOGAND LO \8BITS)) (* round result. low order 8 bits are used for rounding)
(.LRSH8. HI LO)
(COND
((OR (IGREATERP ROUNDINGBITS 128)
(AND (EQ ROUNDINGBITS 128)
(NOT (EQ 0 (LOGAND LO 1))))) (* round up if the left over fraction was greater than
1/2; if it was equal to a half, round to the even
result)
(COND
((EQ LO MAX.SMALL.INTEGER) (* can't add 1 directly)
(SETQ LO 0)
(SETQ HI (ADD1 HI))
(COND
((IGREATERP HI (LOGOR \HIDDENBIT \MAX.HI.FRAC))
(* "1.11111--" became "10.000--")
(SETQ HI (LRSH HI 1))
(add EXP 1))))
(T (SETQ LO (ADD1 LO))))))
(COND
((AND (EQ HI 0)
(EQ LO 0)) (* result is zero. This could have snuck in if we
denormalized a number that didn't have enough digits to
survive)
(GO TOP))
((IGEQ EXP \MAX.EXPONENT)
(* overflow. If trap enabled, wrap the exponent around to middle of range (divide by 2↑\exponentbias) to provide a
number of possible use to error handler)
(SELECTQ \OVERFLOW
(T (RETURN (LISPERROR "FLOATING OVERFLOW" (\MAKEFLOAT SIGN (IDIFFERENCE EXP
\EXPONENT.BIAS)
HI LO NIL BOX)
T)))
NIL)
(RETURN (\INFINITY SIGN BOX))))
(replace SIGNBIT of BOX with SIGN)
(replace EXPONENT of BOX with EXP)
(replace HIFRACTION of BOX with HI)
(replace LOFRACTION of BOX with LO)
(RETURN BOX))))
(MAKEFLOATNUMBER
[LAMBDA (N0 N1) (* lmm "17-DEC-80 20:50")
(* CALLED FROM FETCHFIELD)
(create FLOATP
HIWORD ← N0
LOWORD ← N1])
(PutFloat
[LAMBDA (PTR N) (* lmm "29-Dec-84 11:32")
(* used by REPLACEFIELD)
(\PUTBASEFLOATP PTR 0 N)
N])
(\FZEROP
(LAMBDA (X) (* JonL "27-Sep-84 22:20")
(* Support for generic ZEROP macro)
(AND (EQ 0 (fetch LOWORD of (\DTEST X (QUOTE FLOATP))))
(EQ 0 (fetch HIWORDNOSIGNBIT of X)))))
(MAKERATIONAL
(LAMBDA (X) (* JonL "17-May-84 18:57")
(PROG NIL
RESTART
(RETURN (COND
((FIXP X) (* Integers are already rational)
(CONS (IPLUS X 0)
1))
(T (PROG (SIGN EXP HI LO)
(.FLOATUNBOX. X SIGN EXP HI LO (GO RETZERO)
T RESTART)
(SETQ EXP (IDIFFERENCE EXP (SUB1 \EXPONENT.BIAS)))
(* number of bits to left of binary point)
(COND
((OR (IGREATERP EXP 32)
(AND (EQ EXP 32)
(OR (EQ 0 SIGN)
(NEQ HI \HIDDENBIT)
(NEQ LO 0)))) (* Overflow: number is larger than MAX.INTEGER)
(RETURN (CONS (SELECTQ \OVERFLOW
(T (LISPERROR "OVERFLOW" X T))
(COND
((EQ 0 SIGN)
MAX.INTEGER)
(T MIN.INTEGER)))
1)))) (* Denominator as number stands now is 2↑{24-EXP}.
Now shift right to get rid of excess zeros)
(COND
((ILESSP EXP -6) (* Denominator would overflow a 32-bit integer, so start
throwing out bits)
(FRPTQ (IDIFFERENCE -6 EXP)
(.LRSH1. HI LO))
(SETQ EXP -6)))
(COND
((IGREATERP EXP 24) (* Number is already an integer, need to shift numerator
left, denominator is 1)
(FRPTQ (IMINUS EXP)
(.LLSH1. HI LO))
(SETQ EXP 0))
(T (SETQ EXP (IDIFFERENCE 24 EXP))
(until (OR (ODDP LO)
(EQ 0 EXP))
do (.LRSH1. HI LO)
(add EXP -1))))
(COND
((EQ SIGN 1)
(.NEGATE. HI LO)))
(RETURN (CONS (\MAKENUMBER HI LO)
(.POWEROF2. EXP)))
RETZERO
(RETURN (CONS 0 1)))))))))
)
(PUTPROPS ZEROP DMACRO [OPENLAMBDA (X)
(COND ((EQ X 0))
((FLOATP X)
(\FZEROP X])
(DEFINEQ
(SQRT
[LAMBDA (N) (* lmm "24-Jan-85 19:13")
(PROG ((X (FLOAT N))
V)
(DECLARE (TYPE FLOATP X V))
(if (FLESSP X 0.0)
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 ←(LOGAND (IPLUS \EXPONENT.BIAS
(LRSH (LOGAND (IDIFFERENCE (fetch (FLOATP EXP)
of X)
\EXPONENT.BIAS)
(MASK.1'S 0 BITSPERWORD))
1))
\MAX.EXPONENT)
HIFRACTION ←(fetch (FLOATP HIFRAC) of X)))
(* Exponent is stored as excess \EXPONENT.BIAS and although the LRSH doesn't really do division by 2
(e.g., when the arg is negative) at least the low-order 8 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])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD FLOATP ((SIGNBIT BITS 1)
(EXPONENT BITS 8)
(HIFRACTION BITS 7)
(LOFRACTION BITS 16))
(BLOCKRECORD FLOATP ((HIWORD WORD)
(LOWORD WORD)))
(BLOCKRECORD FLOATP ((NIL BITS 9)
(LONGFRACTION BITS 23)))
(BLOCKRECORD FLOATP ((FLOATCONTENTS BITS 32)))
(BLOCKRECORD FLOATP ((NIL BITS 1)
(HIWORDNOSIGNBIT BITS 15)))
(CREATE (\FLOATBOX (\VAG2 (LOGOR (LLSH SIGNBIT (PLUS 7 8))
(LLSH EXPONENT 7)
HIFRACTION)
LOFRACTION)))
LOFRACTION ← 0 HIFRACTION ← 0 EXPONENT ← 0 SIGNBIT ← 0
[ACCESSFNS FLOATP ((EXP (LOGAND (LRSH (\HILOC (\FLOATUNBOX DATUM))
7)
255))
(HIFRAC (LOGAND (\HILOC (\FLOATUNBOX DATUM))
127])
]
(DECLARE: EVAL@COMPILE
(RPAQQ MAX.DIGITS.ACCURACY 9)
(CONSTANTS (MAX.DIGITS.ACCURACY 9))
)
(* END EXPORTED DEFINITIONS)
(DECLARE: EVAL@COMPILE
(RPAQQ \8BITS 255)
(RPAQQ \MAX.HI.FRAC 127)
(RPAQQ \SIGNBIT 32768)
(RPAQQ \EXPONENT.BIAS 127)
(RPAQQ \HIDDENBIT 128)
(RPAQQ \MAX.EXPONENT 255)
(CONSTANTS (\8BITS 255)
(\MAX.HI.FRAC 127)
(\SIGNBIT 32768)
(\EXPONENT.BIAS 127)
(\HIDDENBIT 128)
(\MAX.EXPONENT 255))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS .FLOATUNBOX. MACRO [(FLONUM SIGN EXP HI LO ZEROFORM DONTSHIFT RESTARTIFINTEGER)
(* Unpacks a floating point number FLONUM into its components. ZEROFORM is evaluated if the number is true zero.
The fraction is unpacked into HI and LO, with the binary point implicitly between bits 0 and 1 of HI.
If DONTSHIFT is true, the fraction is left in its original state, with 8 bits in HI and 16 in LO.
If FLONUM is not floating, it is coerced.)
(PROG NIL
RETRY
[COND
((NOT (FLOATP FLONUM)) (* Float and normalize the non-floatp)
(COND
((QUOTE RESTARTIFINTEGER)
(SETQ FLONUM (LISPERROR "NON-NUMERIC ARG" FLONUM T))
(GO RESTARTIFINTEGER))
(T (SELECTC (NTYPX FLONUM)
[\FIXP (SETQ HI (fetch (FIXP HINUM) of FLONUM))
(SETQ LO (fetch (FIXP LONUM) of FLONUM))
(SETQ SIGN (COND
((IGREATERP HI MAX.POS.HINUM)
(.NEGATE. HI LO)
1)
(T 0]
[\SMALLP (SETQ HI 0)
(SETQ LO (COND
((SMALLPOSP FLONUM)
(SETQ SIGN 0)
FLONUM)
(T (SETQ SIGN 1)
(* FLONUM is negative--negate it)
(COND
((EQ 0 (LOLOC FLONUM))
(* Min small integer)
(SETQ HI 1)
0)
(T (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER
(LOLOC FLONUM]
(PROGN (SETQ FLONUM (FLOAT FLONUM))
(GO RETRY)))
[COND
[(EQ 0 HI)
(COND
((EQ 0 LO)
(SETQ EXP 0)
(PROGN ZEROFORM (RETURN)))
(T (SETQ HI LO)
(SETQ LO 0)
(SETQ EXP (IPLUS \EXPONENT.BIAS 15]
((IGREATERP HI 255) (* Not exact, punt)
(SETQ FLONUM (FLOAT FLONUM))
(GO UNPACK))
(T (SETQ EXP (IPLUS \EXPONENT.BIAS 31]
[COND
((ILEQ HI 255) (* Do a big shift first.)
(.LLSH8. HI LO)
(SETQ EXP (IDIFFERENCE EXP 8]
(while (EQ 0 (LOGAND HI \SIGNBIT))
do (.LLSH1. HI LO)
(SETQ EXP (SUB1 EXP)))
(COND
(DONTSHIFT (.LRSH8. HI LO)))
(RETURN]
UNPACK
(SETQ SIGN (fetch (FLOATP SIGNBIT) of FLONUM))
(SETQ LO (fetch (FLOATP LOFRACTION) of FLONUM))
(SETQ HI (fetch (FLOATP HIFRACTION) of FLONUM))
[COND
[(EQ 0 (SETQ EXP (fetch (FLOATP EXPONENT) of FLONUM)))
(* zero or a de-normalized number from underflow)
(COND
((AND (EQ 0 HI)
(EQ 0 LO)) (* A zero, regardless of the sign bit zero)
ZEROFORM)
(T (* need bias adjust to account for lack of hidden bit)
(SETQ EXP 1]
((NEQ EXP \MAX.EXPONENT) (* might want to check for NaN's here if EXP =
\MAX.EXPONENT)
(* OR in the implicit high bit of fraction)
(SETQ HI (IPLUS HI \HIDDENBIT]
(COND
((NOT DONTSHIFT)
(.LLSH8. HI LO])
(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 .LLSH8. MACRO ((HI LO) (* shift pair left 8, assuming no overflow)
(SETQ HI (IPLUS (LLSH HI 8)
(LRSH LO 8)))
(SETQ LO (LLSH (LOGAND LO \8BITS)
8))))
(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 .LRSH8. MACRO ((HI LO)
(SETQ LO (IPLUS (LRSH LO 8)
(LLSH (LOGAND HI \8BITS)
8)))
(SETQ HI (LRSH HI 8))))
(PUTPROPS .LRSHSTICKY. MACRO ((HI LO) (* shifts pair right one, but low-order bit is sticky
-- if it ever becomes 1, it stays 1)
(SETQ LO (LOGOR (LRSH LO 1)
(LOGAND LO 1)))
[COND
((NEQ (LOGAND HI 1)
0)
(SETQ LO (IPLUS LO \SIGNBIT]
(SETQ HI (LRSH HI 1))))
(PUTPROPS .ADDSMALL2. MACRO [(X Y)
(PROGN (* does X ← X+Y, returning the carry bit)
(COND
((IGREATERP X (IDIFFERENCE MAX.SMALL.INTEGER Y))
[SETQ X (IDIFFERENCE X (IDIFFERENCE MAX.SMALL.INTEGER
(SUB1 Y]
1)
(T (SETQ X (IPLUS X Y))
0])
(PUTPROPS .ADDSMALL3. MACRO [(X Y CARRY)
(PROGN (* X ← X+Y+CARRY, returning the new carry bit)
(COND
((IGREATERP X (IDIFFERENCE (IDIFFERENCE MAX.SMALL.INTEGER Y)
CARRY))
(SETQ X (IDIFFERENCE
X
(IDIFFERENCE [IDIFFERENCE MAX.SMALL.INTEGER
(SUB1 (COND
((EQ Y 0)
(PROG1 CARRY
(SETQ CARRY 0))
)
(T Y]
CARRY)))
1)
(T (SETQ X (IPLUS X Y CARRY))
0])
(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 .POWEROF2. MACRO [OPENLAMBDA (X)
(COND
((ILESSP X 16)
(LLSH 1 X))
(T (LLSH (LLSH 1 (IDIFFERENCE X 16))
16])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ \UNDERFLOW NIL)
(RPAQ MAX.FLOAT (\INFINITY 0))
(RPAQ MIN.FLOAT (\INFINITY 1))
(MOVD? (QUOTE FGREATERP)
(QUOTE FGTP))
)
(* * "unboxed ufns")
(DEFINEQ
(\UNBOXFLOAT1
[LAMBDA (OP) (* hdj " 3-Jan-85 15:04")
(* UFN for the unboxed floating 1-arg cases)
(\SLOWRETURN)
(SELECTQ OP
[0 (* BOX)
(\CALLER.ARGS (X)
(MAKEFLOATNUMBER (\HILOC X)
(\LOLOC X]
(1 (* UNBOX)
(\CALLER.ARGS (X)
(\HAND.FLOATUNBOX X)))
[2 (* UFABS)
(\CALLER.ARGS ((X FLOATP))
(\FLOATUNBOX (ABS X]
[3 (* UFNEGATE)
(\CALLER.ARGS ((X FLOATP))
(\FLOATUNBOX (FMINUS X]
(HELP "\UNBOXFLOAT1 called with illegal op " OP])
(\UNBOXFLOAT2
[LAMBDA (OP) (* lmm " 7-Mar-85 16:48")
(* UFN for the 2-arg floating cases)
(\CALLER.ARGS ((X FLOATP)
(Y FLOATP))
(SELECTQ OP
(0 (* UFADD)
(\HAND.FLOATUNBOX (FPLUS X Y)))
(1 (* UFSUB)
(\HAND.FLOATUNBOX (FDIFFERENCE X Y)))
(2 (* UFISUB)
(\HAND.FLOATUNBOX (FDIFFERENCE Y X)))
(3 (* UFMULT)
(\HAND.FLOATUNBOX (FTIMES X Y)))
(4 (* UFDIV)
(\HAND.FLOATUNBOX (FQUOTIENT X Y)))
(5 (* UFGREAT)
(FGREATERP X Y))
(6 (* UFMAX)
(\HAND.FLOATUNBOX (FMAX X Y)))
(7 (* UFMIN)
(\HAND.FLOATUNBOX (FMIN X Y)))
(8 (* UFREM)
(\HAND.FLOATUNBOX (FREMAINDER X Y)))
(HELP "\UNBOXFLOAT2 called with illegal op " OP])
(\UNBOXFLOAT3
[LAMBDA (OP) (* hdj " 7-Mar-85 10:17")
(SELECTQ OP
[0 (* "polynomial evaluation")
(\CALLER.ARGS ((X FLOATP)
COEFFICIENTS DEGREE)
(bind (A ←(\GETBASEFLOATP COEFFICIENTS 0)) for I from 1 to DEGREE
do [SETQ A (FPLUS (FTIMES A X)
(\GETBASEFLOATP COEFFICIENTS (UNFOLD I
WORDSPERCELL]
finally (RETURN (\FLOATUNBOX A]
(1 (* "3 x 3 matrix multiply")
(\CALLER.ARGS (MATRIX1 MATRIX2 RESULT)
(\MATMULT MATRIX1 MATRIX2 RESULT 3 3 3)))
(2 (* "4 x 4 matrix multiply")
(\CALLER.ARGS (MATRIX1 MATRIX2 RESULT)
(\MATMULT MATRIX1 MATRIX2 RESULT 4 4 4)))
(3 (* "(1,3) * (3,3) => (1,3)")
(\CALLER.ARGS (MATRIX1 MATRIX2 RESULT)
(\MATMULT MATRIX1 MATRIX2 RESULT 1 3 3)))
(4 (* "(3,3) * (3,1) => (3,1)")
(\CALLER.ARGS (MATRIX1 MATRIX2 RESULT)
(\MATMULT MATRIX1 MATRIX2 RESULT 3 3 1)))
(5 (* "(1,4) * (4,4) => (1,4)")
(\CALLER.ARGS (MATRIX1 MATRIX2 RESULT)
(\MATMULT MATRIX1 MATRIX2 RESULT 1 4 4)))
(6 (* "(4,4) * (4,14) => (4,1)")
(\CALLER.ARGS (MATRIX1 MATRIX2 RESULT)
(\MATMULT MATRIX1 MATRIX2 RESULT 4 4 1)))
(HELP "\UNBOXFLOAT3 called with illegal op " OP])
)
(* unboxed arg handling)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \CALLER.ARGS MACRO [X
(LET ((ARGS (CAR X))
(FORMS (CDR X)))
(BQUOTE (PROGN (\SLOWRETURN)
(LET ((AL (\MYALINK))
NEXT ., (for VAR in ARGS collect (if (LISTP VAR)
then (LIST (CAR VAR)
0)
else VAR)))
[DECLARE ., (for VAR in ARGS when (LISTP VAR)
collect (BQUOTE (TYPE , (SELECTQ (CADR VAR)
((FLOATING FLOATP)
(CADR VAR))
(HELP))
,
(CAR VAR]
(SETQ NEXT (fetch (FX NEXTBLOCK) of AL))
.,
[for X in (REVERSE ARGS)
collect (LET [(FORMS (BQUOTE (\.GETBASE32 \STACKSPACE
(SETQ NEXT
(IDIFFERENCE NEXT
WORDSPERCELL]
(if (LISTP X)
then (BQUOTE (SETQ , (CAR X)
(\FLOATBOX , FORMS)))
else (BQUOTE (SETQ , X , FORMS]
(\MAKEFREEBLOCK NEXT (TIMES , (LENGTH ARGS)
WORDSPERCELL))
(replace (FX NEXTBLOCK) of AL with NEXT)
(PROGN ., FORMS])
)
(* END EXPORTED DEFINITIONS)
)
(* * "matrix multiplication")
(DEFINEQ
(MATMULT
[LAMBDA (MATRIXA MATRIXB MATRIXC K M N) (* hdj "12-Feb-85 14:51")
(* * multiply matrices of arbitrary size)
(LET ((MATRIXABASE (fetch (ARRAYP BASE) of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE) of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE) of MATRIXC)))
(\MATMULT MATRIXABASE MATRIXBBASE MATRIXCBASE K M N])
(MATMULT444
[LAMBDA (MATRIXA MATRIXB MATRIXC) (* hdj "12-Feb-85 12:55")
(* * multiply two (4 , 4) matrices in microcode)
(LET ((MATRIXABASE (fetch (ARRAYP BASE) of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE) of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE) of MATRIXC)))
(.MATMULT444 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(MATMULT133
[LAMBDA (MATRIXA MATRIXB MATRIXC) (* hdj "12-Feb-85 12:58")
(* * multiply (1 , 3) * (3 , 3) => (1 , 3))
(LET ((MATRIXABASE (fetch (ARRAYP BASE) of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE) of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE) of MATRIXC)))
(.MATMULT133 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(MATMULT331
[LAMBDA (MATRIXA MATRIXB MATRIXC) (* hdj "12-Feb-85 12:55")
(* * multiply (3 , 3) * (3 , 1) => (3 , 1))
(LET ((MATRIXABASE (fetch (ARRAYP BASE) of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE) of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE) of MATRIXC)))
(.MATMULT331 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(MATMULT333
[LAMBDA (MATRIXA MATRIXB MATRIXC) (* hdj "12-Feb-85 14:50")
(* * multiply two (3 , 3) matrices in microcode)
(LET ((MATRIXABASE (fetch (ARRAYP BASE) of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE) of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE) of MATRIXC)))
(.MATMULT333 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(MATMULT144
[LAMBDA (MATRIXA MATRIXB MATRIXC) (* hdj " 1-Mar-85 15:04")
(* * multiply (1 , 4) * (4 , 4) => (1 , 41))
(LET ((MATRIXABASE (fetch (ARRAYP BASE) of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE) of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE) of MATRIXC)))
(.MATMULT144 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(MATMULT441
[LAMBDA (MATRIXA MATRIXB MATRIXC) (* hdj "12-Feb-85 14:49")
(* * multiply (4 , 4) * (4 , 1) => (4 , 1))
(LET ((MATRIXABASE (fetch (ARRAYP BASE) of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE) of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE) of MATRIXC)))
(.MATMULT441 MATRIXABASE MATRIXBBASE MATRIXCBASE])
)
(DEFINEQ
(\MATMULT
[LAMBDA (ABASE BBASE RESULTBASE L M N) (* hdj " 5-Mar-85 16:58")
[for I from 1 to L do (for J from 1 to N do (\SETELT RESULTBASE I J N
(for K from 1 to M
sum (FTIMES (\GETELT ABASE I K M)
(\GETELT BBASE K J N]
RESULTBASE])
(GETELT
[LAMBDA (ARRAY ROW COLUMN EltsPerRow) (* hdj " 5-Mar-85 17:00")
(\GETBASEFLOATP (fetch (ARRAYP BASE) of ARRAY)
(UNFOLD (IPLUS (SUB1 COLUMN)
(ITIMES (SUB1 ROW)
EltsPerRow))
WORDSPERCELL])
(SETELT
[LAMBDA (ARRAY ROW COLUMN EltsPerRow VALUE) (* hdj " 5-Mar-85 17:01")
(\PUTBASEFLOATP (fetch (ARRAYP BASE) of ARRAY)
(UNFOLD (IPLUS (SUB1 COLUMN)
(ITIMES (SUB1 ROW)
EltsPerRow))
WORDSPERCELL)
VALUE])
(\GETELT
[LAMBDA (ARRAYBASE ROW COLUMN EltsPerRow) (* hdj " 5-Mar-85 16:59")
(\GETBASEFLOATP ARRAYBASE (UNFOLD (IPLUS (SUB1 COLUMN)
(ITIMES (SUB1 ROW)
EltsPerRow))
WORDSPERCELL])
(\SETELT
[LAMBDA (ARRAYBASE ROW COLUMN EltsPerRow VALUE) (* hdj "28-Feb-85 22:55")
(\PUTBASEFLOATP ARRAYBASE (UNFOLD (IPLUS (SUB1 COLUMN)
(ITIMES (SUB1 ROW)
EltsPerRow))
WORDSPERCELL)
VALUE])
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETELT MACRO [ARGS (LET ((ARRAYBASE (CAR ARGS))
(ROW (CADR ARGS))
(COLUMN (CADDR ARGS))
(EltsPerRow (CADDDR ARGS)))
(if (AND (CONSTANTEXPRESSIONP ROW)
(CONSTANTEXPRESSIONP COLUMN)
(CONSTANTEXPRESSIONP EltsPerRow))
then (BQUOTE (\GETBASEFLOATP , ARRAYBASE ,
(UNFOLD (IPLUS (SUB1 COLUMN)
(ITIMES (SUB1 ROW)
EltsPerRow))
WORDSPERCELL)))
else (QUOTE IGNOREMACRO])
(PUTPROPS GETELT MACRO [ARGS (LET ((ARRAY (CAR ARGS))
(ROW (CADR ARGS))
(COLUMN (CADDR ARGS))
(EltsPerRow (CADDDR ARGS)))
(if (AND (CONSTANTEXPRESSIONP ROW)
(CONSTANTEXPRESSIONP COLUMN)
(CONSTANTEXPRESSIONP EltsPerRow))
then (BQUOTE (\GETBASEFLOATP (fetch (ARRAYP BASE)
of , ARRAY)
,
(UNFOLD (IPLUS (SUB1 COLUMN)
(ITIMES (SUB1 ROW)
EltsPerRow))
WORDSPERCELL)))
else (QUOTE IGNOREMACRO])
(PUTPROPS \SETELT MACRO [ARGS (LET [(ARRAYBASE (CAR ARGS))
(ROW (CADR ARGS))
(COLUMN (CADDR ARGS))
(EltsPerRow (CADDDR ARGS))
(VALUE (CADR (CDDDR ARGS]
(if (AND (CONSTANTEXPRESSIONP ROW)
(CONSTANTEXPRESSIONP COLUMN)
(CONSTANTEXPRESSIONP EltsPerRow))
then (BQUOTE (\PUTBASEFLOATP , ARRAYBASE ,
(UNFOLD (IPLUS (SUB1 COLUMN)
(ITIMES (SUB1 ROW)
EltsPerRow))
WORDSPERCELL)
, VALUE))
else (QUOTE IGNOREMACRO])
(PUTPROPS SETELT MACRO [ARGS (LET [(ARRAY (CAR ARGS))
(ROW (CADR ARGS))
(COLUMN (CADDR ARGS))
(EltsPerRow (CADDDR ARGS))
(VALUE (CADR (CDDDR ARGS]
(if (AND (CONSTANTEXPRESSIONP ROW)
(CONSTANTEXPRESSIONP COLUMN)
(CONSTANTEXPRESSIONP EltsPerRow))
then (BQUOTE (\PUTBASEFLOATP (fetch (ARRAYP BASE)
of , ARRAY)
,
(UNFOLD (IPLUS (SUB1 COLUMN)
(ITIMES (SUB1 ROW)
EltsPerRow))
WORDSPERCELL)
, VALUE))
else (QUOTE IGNOREMACRO])
)
(* END EXPORTED DEFINITIONS)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS MATMULT444 DMACRO [LAMBDA (MATRIXA MATRIXB MATRIXC)
(* hdj "12-Feb-85 12:25")
(* * multiply two (4 , 4)
matrices in microcode)
(LET ((MATRIXABASE (fetch (ARRAYP BASE)
of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE)
of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE)
of MATRIXC)))
(.MATMULT444 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS MATMULT133 DMACRO [LAMBDA (MATRIXA MATRIXB MATRIXC)
(* hdj "12-Feb-85 12:28")
(* * multiply (1 , 3)
*
(3 , 3)
=>
(1 , 3))
(LET ((MATRIXABASE (fetch (ARRAYP BASE)
of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE)
of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE)
of MATRIXC)))
(.MATMULT133 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS MATMULT331 DMACRO [LAMBDA (MATRIXA MATRIXB MATRIXC)
(* hdj "12-Feb-85 12:30")
(* * multiply (3 , 3)
*
(3 , 1)
=>
(3 , 1))
(LET ((MATRIXABASE (fetch (ARRAYP BASE)
of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE)
of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE)
of MATRIXC)))
(.MATMULT331 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS MATMULT333 DMACRO [LAMBDA (MATRIXA MATRIXB MATRIXC)
(* hdj "12-Feb-85 12:30")
(* * multiply two (3 , 3)
matrices in microcode)
(LET ((MATRIXABASE (fetch (ARRAYP BASE)
of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE)
of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE)
of MATRIXC)))
(.MATMULT333 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS MATMULT144 DMACRO [LAMBDA (MATRIXA MATRIXB MATRIXC)
(* hdj "12-Feb-85 12:31")
(* * multiply (1 , 4)
*
(4 , 4)
=>
(1 , 41))
(LET ((MATRIXABASE (fetch (ARRAYP BASE)
of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE)
of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE)
of MATRIXC)))
(.MATMULT144 MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS MATMULT441 DMACRO [LAMBDA (MATRIXA MATRIXB MATRIXC)
(* hdj "12-Feb-85 12:32")
(* * multiply (4 , 4)
*
(4 , 1)
=>
(4 , 1))
(LET ((MATRIXABASE (fetch (ARRAYP BASE)
of MATRIXA))
(MATRIXBBASE (fetch (ARRAYP BASE)
of MATRIXB))
(MATRIXCBASE (fetch (ARRAYP BASE)
of MATRIXC)))
(.MATMULT441 MATRIXABASE MATRIXBBASE MATRIXCBASE])
)
(* END EXPORTED DEFINITIONS)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS .MATMULT444 DMACRO [LAMBDA (MATRIXABASE MATRIXBBASE MATRIXCBASE)
(* hdj "12-Feb-85 12:25")
(* * multiply two (4 , 4)
matrices in microcode)
((OPCODES UBFLOAT3 2)
MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS .MATMULT133 DMACRO [LAMBDA (MATRIXABASE MATRIXBBASE MATRIXCBASE)
(* hdj "12-Feb-85 12:28")
(* * multiply (1 , 3)
*
(3 , 3)
=>
(1 , 3))
((OPCODES UBFLOAT3 3)
MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS .MATMULT331 DMACRO [LAMBDA (MATRIXABASE MATRIXBBASE MATRIXCBASE)
(* hdj "12-Feb-85 12:30")
(* * multiply (3 , 3)
*
(3 , 1)
=>
(3 , 1))
((OPCODES UBFLOAT3 4)
MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS .MATMULT333 DMACRO [LAMBDA (MATRIXABASE MATRIXBBASE MATRIXCBASE)
(* hdj "12-Feb-85 12:30")
(* * multiply two (3 , 3)
matrices in microcode)
((OPCODES UBFLOAT3 1)
MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS .MATMULT144 DMACRO [LAMBDA (MATRIXABASE MATRIXBBASE MATRIXCBASE)
(* hdj "12-Feb-85 12:31")
(* * multiply (1 , 4)
*
(4 , 4)
=>
(1 , 41))
((OPCODES UBFLOAT3 5)
MATRIXABASE MATRIXBBASE MATRIXCBASE])
(PUTPROPS .MATMULT441 DMACRO [LAMBDA (MATRIXABASE MATRIXBBASE MATRIXCBASE)
(* hdj "12-Feb-85 12:32")
(* * multiply (4 , 4)
*
(4 , 1)
=>
(4 , 1))
((OPCODES UBFLOAT3 6)
MATRIXABASE MATRIXBBASE MATRIXCBASE])
)
(* END EXPORTED DEFINITIONS)
)
(DEFINEQ
(\FLOATINGSCALE
(LAMBDA (X EXP10 BOX) (* JonL "17-May-84 19:04")
(* Scales X by indicated power of 10, i.e. does
X*10↑EXP10, reusing BOX if supplied.)
(COND
((NOT (FLOATP X))
(SETQ X (FLOAT X))
(OR (FLOATP BOX)
(SETQ BOX X))))
(COND
((EQ 0 EXP10)
(COND
((AND (FLOATP BOX)
(NEQ BOX X))
(replace HIWORD of BOX with (fetch HIWORD of X))
(replace LOWORD of BOX with (fetch LOWORD of X))
BOX)
(T X)))
((IGREATERP EXP10 0)
(COND
((IGREATERP EXP10 29)
(\FLOATINGSCALE (SETQ BOX (\BOXFTIMES2 X (\POWER.OF.TEN 29)
BOX))
(IDIFFERENCE EXP10 29)
BOX))
(T (\BOXFTIMES2 X (\POWER.OF.TEN EXP10)
BOX))))
((ILESSP EXP10 -29)
(\FLOATINGSCALE (SETQ BOX (\BOXFQUOTIENT X (\POWER.OF.TEN 29)
BOX))
(IPLUS EXP10 29)
BOX))
(T (\BOXFQUOTIENT X (\POWER.OF.TEN (IMINUS EXP10))
BOX)))))
(\INIT.POWERS.OF.TEN
[LAMBDA NIL (* bvm: "29-JAN-81 16:33")
(* Initialize array \POWERS.OF.TEN to values 10↑-29 thru 10↑+29. I suppose I could have the array cover the entire
range of floats, but the range is asymmetric and the numbers start losing significance at the ends, so it's not
really worth it)
(SETQ \POWERS.OF.TEN (ARRAY 59 (QUOTE POINTER)))
(SETA \POWERS.OF.TEN 30 1.0)
(for I from 1 to 29 bind POWTEN←1.0 do (SETA \POWERS.OF.TEN (IPLUS I 30)
(SETQ POWTEN (FTIMES POWTEN 10.0)))
(SETA \POWERS.OF.TEN (IDIFFERENCE 30 I)
(FQUOTIENT 1.0 POWTEN)))
\POWERS.OF.TEN])
(\CONVERT.FLOATING.NUMBER
(LAMBDA (X STR STRPTR FORMAT) (* DECLARATIONS: (RECORD FLOATFMT
(WIDTH DECPART EXPPART PAD SIGDIGITS)))
(DECLARE (SPECVARS X CNT POWTEN STR)) (* JonL "17-May-84 19:04")
(PROG ((SIGN (fetch (FLOATP SIGNBIT) of X))
(CNT 0)
(MAXWIDTH (fetch (STRINGP LENGTH) of STR))
EXP POWTEN BOX GUESS DIF DOEXP SIGDIGITS DECDIGITS EXPDIGITS WIDTH)
(* MAXWIDTH is currently 38, I think)
(OR FORMAT (SETQ FORMAT \FLOATFORMAT))
(COND
((AND FORMAT (NEQ FORMAT T))
(SETQ FORMAT (CDR FORMAT))
(COND
((SETQ WIDTH (fetch WIDTH of FORMAT)) (* Currently we use WIDTH only to decide when we must go
to free format)
(COND
((IGREATERP WIDTH MAXWIDTH) (* Can't produce anything larger than our scratch
string)
(SETQ WIDTH MAXWIDTH)))))
(SETQ SIGDIGITS (fetch SIGDIGITS of FORMAT))
(COND
((SETQ EXPDIGITS (fetch EXPPART of FORMAT))
(COND
((EQ 0 EXPDIGITS)
(SETQ EXPDIGITS NIL))
((IGREATERP EXPDIGITS 6) (* avoid scratch string overflow problems)
(SETQ EXPDIGITS 6)))))
(SETQ DECDIGITS (fetch DECPART of FORMAT))
(COND
((AND DECDIGITS (IGREATERP DECDIGITS 20)) (* avoid scratch string overflow)
(SETQ DECDIGITS 20)))
(COND
((AND DECDIGITS EXPDIGITS (NOT SIGDIGITS)) (* Exponent form always has exactly one digit before
point, so...)
(SETQ SIGDIGITS (ADD1 DECDIGITS))))))
(COND
((FEQP X 0.0)
(SETQ X 0)
(SETQ EXP 1)
(SETQ DOEXP EXPDIGITS)
(GO DOIT)))
(COND
((EQ SIGN 1)
(SETQ BOX (SETQ X (FDIFFERENCE 0.0 X)))))
(COND
((NOT SIGDIGITS)
(SETQ SIGDIGITS 7))
((IGREATERP SIGDIGITS 9) (* 9 is the most we can possibly squeeze out of our
floating-point numbers, and that's even pushing it)
(SETQ SIGDIGITS 9))
((ILESSP SIGDIGITS 1)
(SETQ SIGDIGITS 1)))
(SETQ EXP SIGDIGITS) (* EXP is to be the number of digits to the left of the
decimal point in the original number)
(* Scale X to have desired number of digits to left of
decimal point)
(SETQ GUESS (IPLUS (IQUOTIENT (IPLUS (ITIMES (IDIFFERENCE (fetch EXPONENT of X)
\EXPONENT.BIAS)
3)
105)
10)
-9))
(* Guess at the exponent of 10, which is about .3 times the exponent of 2 (LOG10 of 2 = .3010293). The contorted
expression is because IQUOTIENT truncates toward zero, and I want floor. GUESS is guess at the next larger
exponent of 10, hence 1 greater than our estimate of the exponent. GUESS is usually right on, but in case it
isn't, we test below)
(COND
((IGREATERP GUESS 25)
(SETQ X (SETQ BOX (\BOXFQUOTIENT X (\POWER.OF.TEN 25)
BOX)))
(SETQ EXP (IPLUS EXP 25))
(SETQ GUESS (IDIFFERENCE GUESS 25)))
((ILESSP GUESS -25)
(SETQ X (SETQ BOX (\BOXFTIMES2 X (\POWER.OF.TEN 25)
BOX)))
(SETQ EXP (IDIFFERENCE EXP 25))
(SETQ GUESS (IPLUS GUESS 25)))) (* Bring X safely into range of \POWERS.OF.TEN array)
(COND
((FGREATERP (\POWER.OF.TEN GUESS)
X)
(GO SMALLX)))
BIGX(add GUESS 1)
(COND
((NOT (FGREATERP (\POWER.OF.TEN GUESS)
X))
(GO BIGX)))
(GO GOTRANGE)
SMALLX (* exponent of X is less than guess)
(COND
((FGREATERP (\POWER.OF.TEN (SUB1 GUESS))
X)
(SETQ GUESS (SUB1 GUESS))
(GO SMALLX)))
GOTRANGE (* X is between powers GUESS-1 and GUESS)
(SETQ EXP (IPLUS EXP (SETQ DIF (IDIFFERENCE GUESS SIGDIGITS))))
(SETQ DOEXP (OR EXPDIGITS (COND
((NOT DECDIGITS)
(OR (IGREATERP EXP 8)
(ILESSP EXP -4)))
((IGREATERP EXP (IDIFFERENCE (OR WIDTH MAXWIDTH)
(IPLUS DECDIGITS (COND
((EQ SIGN 1)
2)
(T 1)))))
(* Respect DECDIGITS by not switching to exponent format
unless forced by WIDTH)
(SETQ DECDIGITS NIL) (* switch to free format)
T)))) (* Use exponent notation if requested, or if number
would have too many extra digits
(zeros) in normal notation.)
(COND
((NOT (EQ 0 DIF)) (* -DIF is the number of digits to right of decimal
point)
(COND
((AND DECDIGITS (NOT DOEXP)
(ILESSP DECDIGITS (IMINUS DIF))) (* Caller requested fewer decimal places than we would
by default provide, so round sooner)
(SETQ SIGDIGITS (IPLUS SIGDIGITS DIF DECDIGITS))
(SETQ DIF (IMINUS DECDIGITS))))
(COND
((NOT (EQ 0 DIF)) (* Check a second time because DECDIGITS could have been
zero in previous cond)
(SETQ X (SETQ BOX (\FLOATINGSCALE X (IMINUS DIF)
BOX)))))))
(SETQ X (\BOXFPLUSDIF X .5 NIL BOX)) (* round to an integer)
(COND
((NOT (FGREATERP (\POWER.OF.TEN SIGDIGITS)
X)) (* in rounding, we overflowed into next power of 10;
be careful not to round twice now...)
(SETQ X (\BOXFQUOTIENT (\BOXFPLUSDIF X 4.5 NIL X)
10.0 X))
(add EXP 1)))
(SETQ X (FIX X)) (* X now is SIGDIGITS long)
(SETQ POWTEN (NTH (QUOTE (100000000 10000000 1000000 100000 10000 1000 100 10 1))
(IDIFFERENCE 10 SIGDIGITS)))
(* CAR of POWTEN will be integer power of 10 with the 1 in the same place as the high digit of X.
Divide POWTEN by 10 by CDRing)
(COND
((EQ SIGN 1)
(\RPLCHARCODE STR (SETQ CNT 1)
(CHARCODE -))))
DOIT(COND
(DOEXP (* Have to go to exponent notation: n.nnnnEmm)
(\PRODUCE.FDIGIT)
(SETQ EXP (SUB1 EXP)) (* Account for the digit to left of dec pt)
(\RPLCHARCODE STR (add CNT 1)
(CHARCODE %.))
(COND
(DECDIGITS (while (IGEQ (SETQ DECDIGITS (SUB1 DECDIGITS))
0)
do (\PRODUCE.FDIGIT)))
(T (do (\PRODUCE.FDIGIT) repeatuntil (EQ 0 X))))
(\RPLCHARCODE STR (add CNT 1)
(CHARCODE E))
(COND
((ILESSP EXP 0)
(\RPLCHARCODE STR (add CNT 1)
(CHARCODE -))
(SETQ EXP (IMINUS EXP)) (* Count the sign against the exponent count)
(AND EXPDIGITS (SETQ EXPDIGITS (SUB1 EXPDIGITS))))
((AND EXPDIGITS (IGREATERP EXPDIGITS 3))
(* We have room for + in any case)
(\RPLCHARCODE STR (add CNT 1)
(CHARCODE +))
(SETQ EXPDIGITS (SUB1 EXPDIGITS))))
(COND
(EXPDIGITS (FRPTQ (IDIFFERENCE EXPDIGITS (COND
((ILESSP EXP 10)
(* count the chars we know we're printing: E and low
digit)
2)
(T 3)))
(\RPLCHARCODE STR (add CNT 1)
(CHARCODE 0)))))
(COND
((IGEQ EXP 10)
(\RPLCHARCODE STR (add CNT 1)
(IPLUS (CHARCODE 0)
(IQUOTIENT EXP 10)))
(SETQ EXP (IREMAINDER EXP 10))))
(\RPLCHARCODE STR (add CNT 1)
(IPLUS EXP (CHARCODE 0))))
(T (FRPTQ EXP (\PRODUCE.FDIGIT))
(\RPLCHARCODE STR (add CNT 1)
(CHARCODE %.))
(COND
((ILESSP EXP 0)
(COND
(DECDIGITS (COND
((ILESSP EXP (IMINUS DECDIGITS))
(* First sig digit is beyond the allowed dec places)
(SETQ EXP (SETQ X 0)))
(T (SETQ DECDIGITS (IPLUS DECDIGITS EXP))))))
(FRPTQ (IMINUS EXP)
(\RPLCHARCODE STR (add CNT 1)
(CHARCODE 0)))))
(COND
(DECDIGITS (while (IGEQ (SETQ DECDIGITS (SUB1 DECDIGITS))
0)
do (\PRODUCE.FDIGIT)))
(T (do (\PRODUCE.FDIGIT) repeatuntil (EQ 0 X))))))
(RETURN (SUBSTRING STR 1 CNT STRPTR)))))
(\PRODUCE.FDIGIT
(LAMBDA NIL (* JonL "27-Sep-84 22:27")
(DECLARE (USEDFREE CNT STR X POWTEN))
(COND
((EQ 0 X)
(\RPLCHARCODE STR (add CNT 1)
(CHARCODE 0)))
(T (\RPLCHARCODE STR (add CNT 1)
(IPLUS (CHARCODE 0)
(IQUOTIENT X (CAR POWTEN))))
(SETQ X (IREMAINDER X (CAR POWTEN)))
(SETQ POWTEN (CDR POWTEN))))))
)
(DECLARE: DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \POWERS.OF.TEN)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \POWER.OF.TEN MACRO ((N)
(ELT \POWERS.OF.TEN (IPLUS N 30))))
)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\INIT.POWERS.OF.TEN)
)
(DEFINEQ
(FLOATP.TO.BCPL
[LAMBDA (FLONUM) (* bvm: "22-OCT-81 22:31")
(* * Converts a floating point number in IEEE format to an integer in BCPL floating-point format)
(OR (FLOATP FLONUM)
(SETQ FLONUM (FLOAT FLONUM)))
(PROG (RESULT FRAC (EXP (IPLUS (fetch EXPONENT of FLONUM)
2)))
(COND
((FEQP FLONUM 0.0)
(RETURN 0)))
[COND
((IGREATERP EXP 255) (* Overflow, so just return BCPL infinity)
(SETQ EXP 255)
(SETQ FRAC 4194303))
(T (SETQ FRAC (LRSH (fetch LONGFRACTION of FLONUM)
1]
(SETQ RESULT (create BCPLNUM
BCPLEXPONENT ← EXP
SIGNIFICANTBIT ← 1
BCPLHIFRACTION ←(LRSH FRAC 16)
BCPLLOFRACTION ←(LOGAND FRAC MAX.SMALL.INTEGER)))
(RETURN (COND
((EQ (fetch SIGNBIT of FLONUM)
1)
(IMINUS RESULT))
(T RESULT])
(BCPL.TO.FLOATP
[LAMBDA (BCPLNUM) (* bvm: "22-OCT-81 22:34")
(* Converts BCPLNUM, an integer in BCPL floating-point
format, to a FLOATP, which is IEEE standard)
(PROG (SIGN EXP FRAC)
(COND
((ILESSP BCPLNUM 0)
(SETQ BCPLNUM (IMINUS BCPLNUM)) (* In a negative BCPL format, whole number is
complemented)
(SETQ SIGN 1))
((IEQP BCPLNUM 0) (* Canonical form for 0.0)
(RETURN (FPLUS 0.0)))
(T (SETQ SIGN 0)))
(COND
((OR (SMALLP BCPLNUM)
(NEQ (fetch SIGNIFICANTBIT of BCPLNUM)
1))
(ERROR "Not a valid BCPL flonum" BCPLNUM)))
[COND
((ILESSP (SETQ EXP (IDIFFERENCE (fetch BCPLEXPONENT of BCPLNUM)
2))
0) (* Underflow. IEEE exponent is off by 2 because the bias
is one smaller in IEEE format and we shift the mantissa
left one)
(RETURN (FPLUS 0.0]
(SETQ FRAC (LLSH (fetch RESTOFFRACTION of BCPLNUM)
1))
(RETURN (create FLOATP
SIGNBIT ← SIGN
EXPONENT ← EXP
HIFRACTION ←(LRSH FRAC 16)
LOFRACTION ←(LOGAND FRAC MAX.SMALL.INTEGER])
)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD BCPLNUM ((BCPLSIGNBIT BITS 1)
(BCPLEXPONENT BITS 8) (* exponent, biased by 128)
(SIGNIFICANTBIT BITS 1) (* Always 1 in a bcpl num; binary point is to left)
(RESTOFFRACTION BITS 22))
(BLOCKRECORD BCPLNUM ((NIL BITS 10)
(BCPLHIFRACTION BITS 6)
(BCPLLOFRACTION BITS 16)))
(CREATE (CREATECELL \FIXP)))
]
)
(PUTPROPS \UNBOXFLOAT1 ARGNAMES (X OP))
(PUTPROPS \UNBOXFLOAT2 ARGNAMES (X Y OP))
(PUTPROPS \UNBOXFLOAT3 ARGNAMES (X Y Z OP))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FPLUS FTIMES)
)
(PUTPROPS LLFLOAT COPYRIGHT ("Xerox Corporation" 1982 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3585 3937 (\PUTBASEFLOATP 3595 . 3766) (\GETBASEFLOATP 3768 . 3935)) (4443 6074 (FTIMES
4453 . 4974) (FPLUS 4976 . 5372) (FQUOTIENT 5374 . 5515) (FDIFFERENCE 5517 . 5636) (FGREATERP 5638 .
6010) (FABS 6012 . 6072)) (6092 9021 (\SLOWFDIFFERENCE 6102 . 6282) (\SLOWFPLUS2 6284 . 6534) (
\SLOWFTIMES2 6536 . 6704) (\SLOWFQUOTIENT 6706 . 6940) (\SLOWFGREATERP 6942 . 9019)) (9022 29759 (
\FZEROP 9032 . 9374) (FEQP 9376 . 10438) (FLOAT 10440 . 10663) (\FLOAT 10665 . 11518) (
\FIXP.FROM.FLOATP 11520 . 12711) (FIXR 12713 . 14919) (\BOXFPLUSDIF 14921 . 17432) (\BOXFQUOTIENT
17434 . 19621) (\BOXFTIMES2 19623 . 22656) (\INFINITY 22658 . 23385) (\MAKEFLOAT 23387 . 27126) (
MAKEFLOATNUMBER 27128 . 27336) (PutFloat 27338 . 27573) (\FZEROP 27575 . 27917) (MAKERATIONAL 27919 .
29757)) (29866 31132 (SQRT 29876 . 31130)) (39243 43066 (\UNBOXFLOAT1 39253 . 40119) (\UNBOXFLOAT2
40121 . 41358) (\UNBOXFLOAT3 41360 . 43064)) (44508 47527 (MATMULT 44518 . 44946) (MATMULT444 44948 .
45379) (MATMULT133 45381 . 45807) (MATMULT331 45809 . 46235) (MATMULT333 46237 . 46668) (MATMULT144
46670 . 47097) (MATMULT441 47099 . 47525)) (47528 49042 (\MATMULT 47538 . 47900) (GETELT 47902 . 48195
) (SETELT 48197 . 48503) (\GETELT 48505 . 48765) (\SETELT 48767 . 49040)) (56018 67263 (\FLOATINGSCALE
56028 . 57109) (\INIT.POWERS.OF.TEN 57111 . 57832) (\CONVERT.FLOATING.NUMBER 57834 . 66775) (
\PRODUCE.FDIGIT 66777 . 67261)) (67528 69921 (FLOATP.TO.BCPL 67538 . 68528) (BCPL.TO.FLOATP 68530 .
69919)))))
STOP