(FILECREATED "22-May-84 21:05:53" {PHYLUM}<LISPNEW>SOURCES>FEQPPATCH.;2 6775
changes to: (VARS FEQPPATCHCOMS)
previous date: "22-May-84 20:42:20" {PHYLUM}<LISPNEW>SOURCES>FEQPPATCH.;1)
(* Copyright (c) 1984 by Xerox Corporation)
(PRETTYCOMPRINT FEQPPATCHCOMS)
(RPAQQ FEQPPATCHCOMS ((FNS FEQP)
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS FIXP FLOATP)
(MACROS .FLOATUNBOX. .NEGATE. .LLSH1. .LLSH8. LOLOC)
(CONSTANTS \8BITS \HIDDENBIT \MAX.EXPONENT \EXPONENT.BIAS \SIGNBIT
MAX.POS.HINUM MAX.SMALL.INTEGER))))
(DEFINEQ
(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))))))))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD FIXP ((HINUM WORD)
(LONUM WORD))
(CREATE (CREATECELL \FIXP))
(TYPE? (EQ (NTYPX DATUM)
\FIXP)))
(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 (CREATECELL \FLOATP)))
]
(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 .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 .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 LOLOC DMACRO (= . \LOLOC))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \8BITS 255)
(RPAQQ \HIDDENBIT 128)
(RPAQQ \MAX.EXPONENT 255)
(RPAQQ \EXPONENT.BIAS 127)
(RPAQQ \SIGNBIT 32768)
(RPAQQ MAX.POS.HINUM 32767)
(RPAQQ MAX.SMALL.INTEGER 65535)
(CONSTANTS \8BITS \HIDDENBIT \MAX.EXPONENT \EXPONENT.BIAS \SIGNBIT MAX.POS.HINUM MAX.SMALL.INTEGER)
)
)
(PUTPROPS FEQPPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (558 1632 (FEQP 568 . 1630)))))
STOP