(FILECREATED " 5-Aug-86 12:11:32" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;24
 89569  

      changes to:  (VARS CMLARITHCOMS)

      previous date: " 7-Jul-86 12:41:26" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;21)


(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT CMLARITHCOMS)

(RPAQQ CMLARITHCOMS
 
       [(* * "CMLARITH.  Common Lisp Arithmetic.  Covers all of Common Lisp arithmetic except for higher math functions.  Covers sections 2.1-2.1.4, 12.1-12.4, and 12.6-12.10 Doesn't cover sections 12.5-12.5.3."
           )
        (COMS (* "misc")
              (FNS ISQRT PRIMEP PHASE SIGNUM %%SIGNUM))
        (COMS (* "Section 2.1.2 Ratios.")
              (STRUCTURES RATIO)
              (FNS \RATIO.DEFPRINT)
              [DECLARE: DONTEVAL@LOAD DOCOPY (P (* "the following makes NUMBERP true on ratios")
                                                (\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE RATIO))
                                                       (LOGOR \TT.NUMBERP \TT.ATOM))
                                                (DEFPRINT (QUOTE RATIO)
                                                       (QUOTE \RATIO.DEFPRINT]
              (FNS NUMERATOR DENOMINATOR %%BUILD-RATIO RATIONALP RATIONAL RATIONALIZE 
                   %%RATIONALIZE-FLOAT %%RATIO* %%RATIO/ %%RATIO-TIMES-QUOTIENT %%RATIO+ %%RATIO- 
                   %%RATIO-PLUS-DIFFERENCE %%RATIO-INTEGER* %%RATIO-INTEGER+ %%RATIO-INTEGER-))
        (COMS (* "Section 2.1.4 Complex Numbers.")
              (STRUCTURES COMPLEX)
              [DECLARE: DONTEVAL@LOAD DOCOPY (P (* "make it so that COMPLEX is NUMBERP")
                                                (\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE COMPLEX))
                                                       (LOGOR \TT.NUMBERP \TT.ATOM]
              (* "TBW: Reading complex numbers.")
              (FNS COMPLEX REALPART IMAGPART %%COMPLEX+ %%COMPLEX- %%COMPLEX* %%COMPLEX/ 
                   %%COMPLEX-ABS %%COMPLEX-MINUS %%COMPLEX-TIMESI CONJUGATE \PRINT.COMPLEX))
        (COMS (* "Section 12.2 Predicates on Numbers.")
              (* "MINUSP is close enough")
              (FUNCTIONS CL:ZEROP)
              (FNS EVENP ODDP PLUSP))
        (COMS (* "Section 12.4 Arithmetic Operations.")
              (FNS + - CL:* / %%/ 1+ 1-)
              (PROP DMACRO + - CL:* / 1+ 1-)
              (* "CONJUGATE implemented in section 2.1.4 above.")
              (FNS CL:GCD %%GCD LCM))
        (COMS (* "Section 12.6 Type Conversions and Component Extractions on Numbers.")
              (* * "LLFLOAT replacements.  LLFLOAT ufns seem OK once we modify \FLOAT appropriately."
                 )
              (* "NUMERATOR and DENOMINATOR implemented in section 2.1.2 above.")
              (FNS CL:FLOOR TRUNCATE CEILING ROUND CL:MOD REM FFLOOR FCEILING FTRUNCATE FROUND)
              (* "Page 218 functions.")
              (FNS DECODE-FLOAT SCALE-FLOAT FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS FLOAT-PRECISION 
                   INTEGER-DECODE-FLOAT)
              (* "EXPT COMPLEX REALPART and IMAGPART are defined by CMLFLOAT."))
        (COMS (* "Section 12.3 Comparisons on Numbers.")
              (FNS %%= %%>)
              (FNS = %%= /= < > <= >=)
              (PROP DMACRO = /= < > <= >=)
              (* "MAX and MIN are OK"))
        [COMS (* "new general arithmetic UFNs which know about ratio and complex")
              (* "NOTE: %%/ CAN NOT COMPILE INTO THE EXISTING QUOTIENT OPCODE.  This is because %%/ is supposed to produce a rational when numerator is not evenly divisible by denominator.  Therefore, there is no MACRO for %%/ below."
                 )
              (PROP DOPVAL %%+ %%- %%* %%>)
              (FNS %%+ %%- %%* %%/)
              (DECLARE: DONTEVAL@LOAD DOCOPY (P (\SETUFNENTRY (CAR (\FINDOP (QUOTE PLUS2)))
                                                       (QUOTE %%+)
                                                       2 0)
                                                (\SETUFNENTRY (CAR (\FINDOP (QUOTE DIFFERENCE)))
                                                       (QUOTE %%-)
                                                       2 0)
                                                (\SETUFNENTRY (CAR (\FINDOP (QUOTE TIMES2)))
                                                       (QUOTE %%*)
                                                       2 0)
                                                (\SETUFNENTRY (CAR (\FINDOP (QUOTE GREATERP)))
                                                       (QUOTE %%>)
                                                       2 0]
        (COMS (* "Section 12.7 Logical Operations on Numbers.")
              (* "Page 221 functions.  LOGAND LOGXOR are OK.")
              (FNS LOGIOR LOGEQV LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2)
              (* "Page 222.0 BOOLE and constants.")
              (FNS BOOLE)
              (VARIABLES BOOLE-CLR BOOLE-SET BOOLE-1 BOOLE-2 BOOLE-C1 BOOLE-C2 BOOLE-AND BOOLE-IOR 
                     BOOLE-XOR BOOLE-EQV BOOLE-NAND BOOLE-NOR BOOLE-ANDC1 BOOLE-ANDC2 BOOLE-ORC1 
                     BOOLE-ORC2)
              (* "Remainder of section 12.7 LOGNOT is OK.")
              (FNS LOGTEST LOGBITP)
              (FNS ASH)
              (FNS LOGCOUNT %%LOGCOUNT)
              (FNS INTEGER-LENGTH))
        (COMS (* "Section 12.8 Byte Manipulations Functions.")
              (* "BYTE macro already implemented.  Should be function.")
              (FNS BYTE-SIZE BYTE-POSITION)
              (* "LDB macro already implemented.  Should be function.")
              (FNS LDB-TEST MASK-FIELD)
              (* "DPB macro already implemented.  Should be function.")
              (FNS DEPOSIT-FIELD))
        (COMS (* 
    "Section 12.10, implementation parameters.  The constants in this COMS are exported to the user."
                 )
              (FUNCTIONS **FLOAT**)
              (VARIABLES MOST-POSITIVE-FIXNUM MOST-NEGATIVE-FIXNUM MOST-POSITIVE-SINGLE-FLOAT 
                     LEAST-POSITIVE-SINGLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT 
                     MOST-NEGATIVE-SINGLE-FLOAT MOST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SHORT-FLOAT 
                     LEAST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SHORT-FLOAT MOST-POSITIVE-DOUBLE-FLOAT 
                     LEAST-POSITIVE-DOUBLE-FLOAT LEAST-NEGATIVE-DOUBLE-FLOAT 
                     MOST-NEGATIVE-DOUBLE-FLOAT MOST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-LONG-FLOAT 
                     LEAST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-LONG-FLOAT)
              (* "EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON)))"
                 )
              (VARIABLES SINGLE-FLOAT-EPSILON SHORT-FLOAT-EPSILON DOUBLE-FLOAT-EPSILON 
                     LONG-FLOAT-EPSILON)
              (* "NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON)))"
                 )
              (VARIABLES SINGLE-FLOAT-NEGATIVE-EPSILON SHORT-FLOAT-NEGATIVE-EPSILON 
                     DOUBLE-FLOAT-NEGATIVE-EPSILON LONG-FLOAT-NEGATIVE-EPSILON))
        (DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                               LLFLOAT LLBIGNUM))
        (PROP FILETYPE CMLARITH)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA DEPOSIT-FIELD MASK-FIELD LDB-TEST BYTE-POSITION BYTE-SIZE LOGCOUNT 
                            LOGBITP LOGTEST BOOLE LOGORC2 LOGORC1 LOGANDC2 LOGANDC1 LOGNOR LOGNAND 
                            LOGEQV LOGIOR >= <= > < /= = INTEGER-DECODE-FLOAT FLOAT-PRECISION 
                            FLOAT-DIGITS FLOAT-SIGN FLOAT-RADIX DECODE-FLOAT FROUND FTRUNCATE 
                            FCEILING FFLOOR REM CL:MOD ROUND CEILING TRUNCATE CL:FLOOR LCM %%GCD 
                            CL:GCD / CL:* - + PLUSP ODDP EVENP \PRINT.COMPLEX %%COMPLEX-TIMESI 
                            %%COMPLEX-MINUS %%COMPLEX-ABS %%COMPLEX/ %%COMPLEX* %%COMPLEX- %%COMPLEX+ 
                            IMAGPART REALPART COMPLEX %%RATIO-INTEGER- %%RATIO-INTEGER+ 
                            %%RATIO-INTEGER* %%RATIO-PLUS-DIFFERENCE %%RATIO- %%RATIO+ 
                            %%RATIO-TIMES-QUOTIENT %%RATIO/ %%RATIO* %%RATIONALIZE-FLOAT RATIONALIZE 
                            RATIONAL %%BUILD-RATIO DENOMINATOR NUMERATOR %%SIGNUM SIGNUM PHASE PRIMEP 
                            ISQRT])
(* * 
"CMLARITH.  Common Lisp Arithmetic.  Covers all of Common Lisp arithmetic except for higher math functions.  Covers sections 2.1-2.1.4, 12.1-12.4, and 12.6-12.10 Doesn't cover sections 12.5-12.5.3."
)





(* "misc")


(DEFINEQ

(ISQRT

  (CL:LAMBDA (N)
                                             (* kbr: " 1-Apr-86 12:11")

          
          (* ISQRT: Integer square root -

          isqrt (n) **2 <= n Upper and lower bounds on the result are estimated using 

          integer-length. On each iteration, one of the bounds is replaced by their mean.

          The lower bound is returned when the bounds meet or differ by only 1.0 Initial 

          bounds guarantee that lg (sqrt (n)) = lg

          (n) /2 iterations suffice. *)


         (CL:IF (AND (INTEGERP N)
                     (NOT (MINUSP N)))
                [CL:DO* [(LG (INTEGER-LENGTH
 N))
                         (LO (ASH
 1 (ASH
 (1-
 LG)
                                         -1)))
                         (HI (+
 LO (ASH
 LO (CL:IF (ODDP
 LG)
                                                  -1 0]
                       ((<=
 (1-
 HI)
                         LO)
                        LO)
                       (LET ((MID (ASH
 (+
 LO HI)
                                       -1)))
                            (CL:IF (<=
 (CL:*
 MID MID)
                                    N)
                                   (SETQ LO MID)
                                   (SETQ HI MID]
                (CL:ERROR "Isqrt: ~S argument must be a nonnegative integer" N))))

(PRIMEP

  [CL:LAMBDA (X)
                                             (* kbr: " 7-Apr-86 20:54")

                                                             (* Returns T iff X is a positive prime 

                                                             integer. *)

         (CL:IF (<=
 X 5)
                (AND (>=
 X 2)
                     (/=
 X 4))
                (AND (NOT (EVENP
 X))
                     (NOT (=
 0 (REM
 X 3)))
                     (CL:DO ((Q 6)
                             (R 1)
                             (INC 2 (LOGXOR INC 6))
                             (D 5 (+
 D INC)))
                            ((OR (=
 R 0)
                                 (>
 D Q))
                             (/=
 R 0))
                            (MULTIPLE-VALUE-SETQ (Q R)
                                   (TRUNCATE
 X D])

(PHASE

  (CL:LAMBDA (NUMBER)
         (COND
            ((COMPLEXP NUMBER)
             (CL:ATAN (COMPLEX-IMAGPART NUMBER)
                    (COMPLEX-REALPART NUMBER)))
            ((MINUSP NUMBER)
             PI)
            (T 0))))

(SIGNUM

  [CL:LAMBDA (NUMBER)
                                        (* kbr: "13-May-86 17:10")

                                                             (* If NUMBER is zero, return NUMBER, 

                                                             else return (/ NUMBER

                                                             (ABS NUMBER))%. Currently not 

                                                             implemented for complex numbers.

                                                             *)

         (COND
            ((ZEROP NUMBER)
             NUMBER)
            (T (COND
                  ((RATIONALP
 NUMBER)
                   (COND
                      ((PLUSP
 NUMBER)
                       1)
                      (T -1)))
                  (T (/
 NUMBER (ABS NUMBER])

(%%SIGNUM

  (CL:LAMBDA (X)
         (LET [(RES (COND
                       ((PLUSP
 X)
                        1)
                       ((ZEROP X)
                        0)
                       (T -1]
              (CL:IF (FLOATP X)
                     (FLOAT RES X)
                     RES))))
)



(* "Section 2.1.2 Ratios.")


(DEFSTRUCT (RATIO
 (:CONSTRUCTOR %%MAKE-RATIO (NUMERATOR DENOMINATOR))) (NUMERATOR :READ-ONLY)
   (DENOMINATOR :READ-ONLY))

(DEFINEQ

(\RATIO.DEFPRINT

  [LAMBDA (NUMBER STREAM)
                                    (* bvm: " 3-Aug-86 16:08")

    [LET ((TOP (NUMERATOR
 NUMBER))
          (BOTTOM (DENOMINATOR
 NUMBER)))
         (if
 (NOT (fetch
 (READTABLEP COMMONNUMSYNTAX) of
 *READTABLE*))
             then
                                            (* Can't print nice ratios to old read 

                                                             tables)

                  (PRIN1 "|." STREAM)
                  (\PRINDATUM (LIST (QUOTE /)
                                    TOP BOTTOM)
                         STREAM)
           else
 (LET (*PRINT-RADIX*)
          
          (* Can't have radix specifier in ratio, but ratio must print in current base.

          Note that this means you'd better always read and print in same base, since 

          radix specifiers can't help you here)


                     (.SPACECHECK. STREAM (IPLUS 1 (NCHARS TOP)
                                                 (NCHARS BOTTOM)))
                     (LET (\THISFILELINELENGTH)
                          (DECLARE
 (SPECVARS \THISFILELINELENGTH))
                                                             (* Turn off linelength check just in 

                                                             case the NCHARS count is off because 

                                                             of radices)

                          (\PRINDATUM TOP STREAM)
                          (PRIN3 "/" STREAM)
                          (\PRINDATUM BOTTOM STREAM]
    T])
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(* "the following makes NUMBERP true on ratios")
(\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE RATIO))
       (LOGOR \TT.NUMBERP \TT.ATOM))
(DEFPRINT (QUOTE RATIO)
       (QUOTE \RATIO.DEFPRINT))
)
(DEFINEQ

(NUMERATOR

  [CL:LAMBDA (X)
                                             (* lmm "22-May-86 15:44")

                                                             (* Returns the numerator of a 

                                                             rational.)

         (ETYPECASE X (INTEGER X)
                (RATIO (RATIO-NUMERATOR X])

(DENOMINATOR

  [CL:LAMBDA (X)
                                             (* lmm "22-May-86 15:43")

                                                             (* Returns the denominator of a 

                                                             rational. *)

         (ETYPECASE X (INTEGER 1)
                (RATIO (RATIO-DENOMINATOR X])

(%%BUILD-RATIO

  [CL:LAMBDA (X Y)
                                           (* kbr: " 8-May-86 22:13")

                                                             (* %%BUILD-RATIO takes two integer 

                                                             arguments and builds the rational 

                                                             number which is their quotient.

                                                             *)

         (MULTIPLE-VALUE-BIND (Q R)
                (TRUNCATE
 X Y)
                (CL:IF (ZEROP R)
                       Q
                       (LET ((CL:GCD
 (%%GCD
 X Y)))
                            [CL:UNLESS (=
 CL:GCD 1)
                                   (PROGN (SETQ X (/
 X CL:GCD))
                                          (SETQ Y (/
 Y CL:GCD]
                            (CL:IF (MINUSP Y)
                                   (%%MAKE-RATIO (-
 X)
                                          (-
 Y))
                                   (%%MAKE-RATIO X Y])

(RATIONALP

  [LAMBDA (NUMBER)
                                           (* lmm "22-May-86 15:45")

    (OR (INTEGERP NUMBER)
        (RATIO-P NUMBER])

(RATIONAL

  [CL:LAMBDA (NUMBER)
                                        (* lmm "19-Jun-86 14:42")

                                                             (* Rational produces a rational number 

                                                             for any numeric argument.

                                                             Rational assumed that the floating 

                                                             point is completely accurate.

                                                             *)

         (ETYPECASE NUMBER (INTEGER NUMBER)
                (FLOAT (MULTIPLE-VALUE-BIND (F E SIGN)
                              (DECODE-FLOAT
 NUMBER)
                              (LET* [(PRECISION (FLOAT-PRECISION
 F))
                                     (F (TRUNCATE
 (SCALE-FLOAT
 F PRECISION)))
                                     (V (CL:IF (MINUSP E)
                                               (%%BUILD-RATIO
 F (ASH
 1 (-
 PRECISION E)))
                                               (%%BUILD-RATIO
 (ASH
 F E)
                                                      (ASH
 1 PRECISION]
                                    V)))
                (RATIO NUMBER)
                (COMPLEX
 (%%MAKE-COMPLEX (RATIONAL
 (REALPART
 NUMBER))
                                (RATIONAL
 (IMAGPART
 NUMBER])

(RATIONALIZE

  [CL:LAMBDA (X)
                                             (* lmm "19-Jun-86 14:42")

                                                             (* Rationalize does a rational, but it 

                                                             assumes that floats are only accurate 

                                                             to their precision, and generates a 

                                                             good rational aproximation of them.

                                                             *)

         (ETYPECASE X ((OR INTEGER RATIO)
                       X)
                (FLOAT (%%RATIONALIZE-FLOAT
 X SINGLE-FLOAT-EPSILON))
                (COMPLEX
 (%%MAKE-COMPLEX (RATIONALIZE
 (REALPART
 X))
                                (RATIONALIZE
 (IMAGPART
 X])

(%%RATIONALIZE-FLOAT

  [CL:LAMBDA (X &OPTIONAL (EPS LONG-FLOAT-EPSILON))
          (* kbr: " 8-May-86 17:35")

                                                             (* Produce a rational approximating X.

                                                             *)

         (COND
            [(MINUSP X)
             (-
 (RATIONALIZE
 (-
 X]
            ((ZEROP X)
             0)
            (T (LET ((Y NIL)
                     (A NIL))
                    (CL:DO ([XX X (SETQ Y (/
 1.0 (-
 XX (FLOAT A X]
                            (NUM (SETQ A (TRUNCATE
 X))
                                 (+
 (CL:*
 (SETQ A (TRUNCATE
 Y))
                                          NUM)
                                    ONUM))
                            (DEN 1 (+
 (CL:*
 A DEN)
                                      ODEN))
                            (ONUM 1 NUM)
                            (ODEN 0 DEN))
                           ((AND (NOT (ZEROP DEN))
                                 (NOT (>
 (ABS (/
 (-
 X (/
 (FLOAT NUM X)
                                                         (FLOAT DEN X)))
                                                 X))
                                         EPS)))
                            (/
 NUM DEN])

(%%RATIO*

  (CL:LAMBDA (X Y)
                                           (* kbr: " 8-Apr-86 16:10")

                                                             (* %%RATIO* does a ratio to ratio 

                                                             multiplication. %%RATIO/ does a ratio 

                                                             to ratio division. *)

         (LET* ((NUMX (NUMERATOR
 X))
                (NUMY (NUMERATOR
 Y))
                (DENX (DENOMINATOR
 X))
                (DENY (DENOMINATOR
 Y)))
               (%%RATIO-TIMES-QUOTIENT
 NUMX DENX NUMY DENY))))

(%%RATIO/

  [CL:LAMBDA (X Y)
                                           (* kbr: " 8-Apr-86 14:02")

         (LET* ((NUMX (NUMERATOR
 X))
                (NUMY (NUMERATOR
 Y))
                (DENX (DENOMINATOR
 X))
                (DENY (DENOMINATOR
 Y)))
               (CL:IF (MINUSP NUMY)
                      (%%RATIO-TIMES-QUOTIENT
 NUMX DENX (-
 DENY)
                             (-
 NUMY))
                      (%%RATIO-TIMES-QUOTIENT
 NUMX DENX DENY NUMY])

(%%RATIO-TIMES-QUOTIENT

  [CL:LAMBDA (H1 K1 H2 K2)
                                   (* kbr: " 8-Apr-86 16:40")

         [LET ((GCDH1K2 (%%GCD
 H1 K2))
               (GCDH2K1 (%%GCD
 H2 K1)))
              [CL:UNLESS (=
 GCDH1K2 1)
                     (PROGN (SETQ H1 (/
 H1 GCDH1K2))
                            (SETQ K2 (/
 K2 GCDH1K2]
              (CL:UNLESS (=
 GCDH2K1 1)
                     (PROGN (SETQ H2 (/
 H2 GCDH2K1))
                            (SETQ K1 (/
 K1 GCDH2K1]
         (LET ((H (CL:*
 H1 H2))
               (K (CL:*
 K1 K2)))
              (CL:IF (=
 K 1)
                     H
                     (%%MAKE-RATIO H K])

(%%RATIO+

  (CL:LAMBDA (X Y)                                           (* %%sp-ratio+ does a ratio to ratio 

                                                             addition. %%sp-ratio-

                                                             does a ratio to ratio subtraction.

                                                             VM:T *)

         (%%RATIO-PLUS-DIFFERENCE
 X Y NIL)))

(%%RATIO-

  (CL:LAMBDA (X Y)
         (%%RATIO-PLUS-DIFFERENCE
 X Y T)))

(%%RATIO-PLUS-DIFFERENCE

  [CL:LAMBDA (X Y DIFFERENCEFLG)
                             (* kbr: " 8-May-86 21:08")

         (LET* ((H1 (NUMERATOR
 X))
                (K1 (DENOMINATOR
 X))
                (H2 (NUMERATOR
 Y))
                (K2 (DENOMINATOR
 Y))
                (D1 (%%GCD
 K1 K2)))
               (CL:WHEN DIFFERENCEFLG (SETQ H2 (-
 H2)))
               (CL:IF (=
 D1 1)
                      (%%MAKE-RATIO (+
 (CL:*
 H1 K2)
                                       (CL:*
 H2 K1))
                             (CL:*
 K1 K2))
                      (LET* ((K1/D1 (/
 K1 D1))
                             (TEE (+
 (CL:*
 H1 (/
 K2 D1))
                                     (CL:*
 H2 K1/D1)))
                             (D2 (%%GCD
 TEE D1))
                             (K2/D2 K2))
                            [CL:UNLESS (=
 D2 1)
                                   (PROGN (SETQ K2/D2 (/
 K2 D2))
                                          (SETQ TEE (/
 TEE D2]
                            (CL:IF (=
 K1/D1 1 K2/D2)
                                   TEE
                                   (%%MAKE-RATIO TEE (CL:*
 K1/D1 K2/D2])

(%%RATIO-INTEGER*

  [CL:LAMBDA (X Y)
                                           (* kbr: " 8-Apr-86 20:19")

                                                             (* %%RATIO-INTEGER* multiplies a ratio 

                                                             by an integer. *)

         (CL:IF (ZEROP Y)
                0
                (LET* ((DEN (DENOMINATOR
 X))
                       (CL:GCD
 (%%GCD
 DEN Y)))
                      [CL:UNLESS (=
 CL:GCD 1)
                             (PROGN (SETQ Y (/
 Y CL:GCD))
                                    (SETQ DEN (/
 DEN CL:GCD]
                      (CL:IF (=
 DEN 1)
                             (CL:*
 (NUMERATOR
 X)
                                   Y)
                             (%%MAKE-RATIO (CL:*
 (NUMERATOR
 X)
                                                 Y)
                                    DEN])

(%%RATIO-INTEGER+

  (CL:LAMBDA (X Y)
                                           (* lmm "22-May-86 15:41")

                                                             (* %%RATIO-INTEGER+ adds an integer to 

                                                             a ratio. *)

         (LET ((DENX (RATIO-DENOMINATOR X)))
              (%%MAKE-RATIO (+
 (RATIO-NUMERATOR X)
                               (CL:*
 DENX Y))
                     DENX))))

(%%RATIO-INTEGER-

  (CL:LAMBDA (X Y)
                                           (* lmm "22-May-86 15:41")

                                                             (* %%RATIO-INTEGER- subtracts an 

                                                             integer from a ratio.

                                                             *)

         (LET ((DENX (RATIO-DENOMINATOR X)))
              (%%MAKE-RATIO (-
 (RATIO-NUMERATOR X)
                               (CL:*
 DENX Y))
                     DENX))))
)



(* "Section 2.1.4 Complex Numbers.")


(DEFSTRUCT (COMPLEX
 (:PREDICATE COMPLEXP)
                    (:CONSTRUCTOR %%MAKE-COMPLEX (REALPART IMAGPART))
                    (:PRINT-FUNCTION \PRINT.COMPLEX)) (REALPART :READ-ONLY) (IMAGPART :READ-ONLY))

(DECLARE: DONTEVAL@LOAD DOCOPY 
(* "make it so that COMPLEX is NUMBERP")
(\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE COMPLEX))
       (LOGOR \TT.NUMBERP \TT.ATOM))
)



(* "TBW: Reading complex numbers.")


(DEFINEQ

(COMPLEX

  [CL:LAMBDA (REALPART
 &OPTIONAL (IMAGPART
 0))
               (* lmm "27-Jun-86 22:34")

                                                             (* Builds a complex number from the 

                                                             specified components.

                                                             *)

         (CTYPECASE REALPART [RATIONAL
 (CL:IF (EQL IMAGPART 0)
                                              REALPART
                                              (CTYPECASE IMAGPART (RATIONAL
 (%%MAKE-COMPLEX REALPART 
                                                                                   IMAGPART))
                                                     (FLOAT (%%MAKE-COMPLEX (FLOAT REALPART)
                                                                   IMAGPART]
                (FLOAT (%%MAKE-COMPLEX REALPART (FLOAT IMAGPART])

(REALPART

  (CL:LAMBDA (NUMBER)
                                        (* lmm "22-May-86 16:19")

         (ETYPECASE NUMBER (COMPLEX
 (COMPLEX-REALPART NUMBER))
                (NUMBER NUMBER))))

(IMAGPART

  (CL:LAMBDA (NUMBER)
                                        (* lmm "22-May-86 16:56")

         (ETYPECASE NUMBER (COMPLEX
 (COMPLEX-IMAGPART NUMBER))
                (FLOAT 0.0)
                (NUMBER 0))))

(%%COMPLEX+

  [CL:LAMBDA (X Y)                                           (* addition *)

         (COMPLEX
 (+
 (REALPART
 X)
                     (REALPART
 Y))
                (+
 (IMAGPART
 X)
                   (IMAGPART
 Y])

(%%COMPLEX-

  [CL:LAMBDA (X Y)                                           (* subtraction *)

         (COMPLEX
 (-
 (REALPART
 X)
                     (REALPART
 Y))
                (-
 (IMAGPART
 X)
                   (IMAGPART
 Y])

(%%COMPLEX*

  [CL:LAMBDA (Z1 Z2)                                         (* multiplication *)

         (LET* ((R1 (REALPART
 Z1))
                (C1 (IMAGPART
 Z1))
                (R2 (REALPART
 Z2))
                (C2 (IMAGPART
 Z2)))
               (COMPLEX
 (-
 (CL:*
 R1 R2)
                           (CL:*
 C1 C2))
                      (+
 (CL:*
 C1 R2)
                         (CL:*
 R1 C2])

(%%COMPLEX/

  [CL:LAMBDA (Z1 Z2)
                                         (* kbr: "23-Apr-86 00:05")

                                                             (* complex division *)

         (LET* ((R1 (REALPART
 Z1))
                (C1 (IMAGPART
 Z1))
                (R2 (REALPART
 Z2))
                (C2 (IMAGPART
 Z2))
                (CONS1 (CL:*
 R2 R2))
                (CONS2 (CL:*
 C2 C2))
                (MULT1 (CL:*
 R1 R2)))
               (COMPLEX
 (/
 (+
 MULT1 (CL:*
 C1 C2))
                           (+
 CONS1 CONS2))
                      (/
 (-
 (CL:*
 C1 R2)
                            (CL:*
 R1 C2))
                         (+
 CONS1 CONS2])

(%%COMPLEX-ABS

  [CL:LAMBDA (Z)
                                             (* lmm "27-Jun-86 22:36")

         (LET ((X (COMPLEX-REALPART Z))
               (Y (COMPLEX-IMAGPART Z)))
              (CL:SQRT (+
 (CL:*
 X X)
                          (CL:*
 Y Y])

(%%COMPLEX-MINUS

  [CL:LAMBDA (Z)
                                             (* kbr: " 8-Apr-86 00:06")

         (COMPLEX
 (-
 (REALPART
 Z))
                (-
 (IMAGPART
 Z])

(%%COMPLEX-TIMESI

  (CL:LAMBDA (Z)
                                             (* kbr: " 8-Apr-86 00:06")

                                                             (* multiplying i (the square root of 

                                                             -1) times a number *)

         (COMPLEX
 (-
 (IMAGPART
 Z))
                (REALPART
 Z))))

(CONJUGATE

  [LAMBDA (NUMBER)
                                           (* lmm "22-May-86 16:57")

    (ETYPECASE NUMBER [COMPLEX
 (%%MAKE-COMPLEX (COMPLEX-REALPART NUMBER)
                                      (-
 (COMPLEX-IMAGPART NUMBER]
           (NUMBER NUMBER])

(\PRINT.COMPLEX

  (CL:LAMBDA (COMPLEX
 STREAM)
                                (* lmm "26-Jun-86 10:31")

         (FORMAT STREAM "~CC(~S ~S)" (INT-CHAR (fetch
 (READTABLEP HASHMACROCHAR) of
 *READTABLE*))
                (COMPLEX-REALPART COMPLEX)
                (COMPLEX-IMAGPART COMPLEX))))
)



(* "Section 12.2 Predicates on Numbers.")





(* "MINUSP is close enough")


(DEFUN CL:ZEROP
 (NUMBER) (= NUMBER 0))

(DEFINEQ

(EVENP

  (CL:LAMBDA (NUMBER &OPTIONAL (MODULUS 2))
                  (* lmm "22-May-86 17:25")

         (ZEROP (CL:MOD
 NUMBER MODULUS))))

(ODDP

  [CL:LAMBDA (NUMBER &OPTIONAL (MODULUS 2))
                  (* lmm "22-May-86 17:26")

         (NOT (ZEROP (CL:MOD
 NUMBER MODULUS])

(PLUSP

  (CL:LAMBDA (NUMBER)
                                        (* lmm "22-May-86 16:59")

         (>
 NUMBER 0)))
)



(* "Section 12.4 Arithmetic Operations.")


(DEFINEQ

(+

  [LAMBDA N
                                                  (* kbr: " 6-May-86 16:02")

                                                             (* Microcode generally handles the 

                                                             case of two args both FIXPs)

    (PROG (A R J)
          (COND
             ((EQ N 0)
              (RETURN 0)))
          (SETQ R (ARG N 1))
          (SETQ J 1)
      LP  (COND
             ((NOT (EQ J N))
              (SETQ J (ADD1 J))
              (SETQ A (ARG N J))
              (SETQ R (%%+
 R A))
              (GO LP)))
          (RETURN R])

(-

  [LAMBDA N
                                                  (* kbr: " 8-May-86 17:25")

    (PROG (A R J)
          (COND
             ((EQ N 1)
              (SETQ A (ARG N 1))
              (SETQ R (%%-
 0 A))
              (RETURN R)))
          (SETQ R (ARG N 1))
          (SETQ J 1)
      LP  (COND
             ((NOT (EQ J N))
              (SETQ J (ADD1 J))
              (SETQ A (ARG N J))
              (SETQ R (%%-
 R A))
              (GO LP)))
          (RETURN R])

(CL:*

  [LAMBDA N
                                                  (* kbr: " 6-May-86 17:02")

    (PROG (A R J)
          (COND
             ((EQ N 0)
              (RETURN 1)))
          (SETQ R (ARG N 1))
          (SETQ J 1)
      LP  (COND
             ((NOT (EQ J N))
              (SETQ J (ADD1 J))
              (SETQ A (ARG N J))
              (SETQ R (%%*
 R A))
              (GO LP)))
          (RETURN R])

(/

  [CL:LAMBDA (NUMBER &REST NUMBERS)
                          (* kbr: " 6-May-86 18:28")

         (COND
            ((NULL NUMBERS)
             (%%/
 1 NUMBER))
            (T (for
 X in
 NUMBERS do
 (SETQ NUMBER (%%/
 NUMBER X)) finally
 (RETURN NUMBER])

(%%/

  [LAMBDA (N1 N2)
                                            (* lmm "19-Jun-86 15:43")

    (\CALLME (QUOTE /))                                      (* UFN for / Microcode generally 

                                                             handles the case of two args both 

                                                             FIXPs)

    (CTYPECASE N1 [INTEGER (CTYPECASE N2 [INTEGER (COND
                                                     ((EVENP
 N1 N2)
                                                      (IQUOTIENT N1 N2))
                                                     (T (%%BUILD-RATIO
 N1 N2]
                                  (FLOAT (FQUOTIENT N1 N2))
                                  (RATIO (%%/
 (CL:*
 (DENOMINATOR
 N2)
                                                    N1)
                                              (NUMERATOR
 N2)))
                                  (COMPLEX
 (%%COMPLEX/
 (%%MAKE-COMPLEX N1 0)
                                                  N2]
           [FLOAT (CTYPECASE N2 ((OR INTEGER FLOAT)
                                 (FQUOTIENT N1 N2))
                         (RATIO (%%/
 (CL:*
 (DENOMINATOR
 N2)
                                           N1)
                                     (NUMERATOR
 N2)))
                         (COMPLEX
 (%%COMPLEX/
 (%%MAKE-COMPLEX N1 0.0)
                                         N2]
           [RATIO (CTYPECASE N2 (INTEGER (%%BUILD-RATIO
 (NUMERATOR
 N1)
                                                (CL:*
 (DENOMINATOR
 N1)
                                                      N2)))
                         (FLOAT (FQUOTIENT N1 N2))
                         (RATIO (%%RATIO/
 N1 N2))
                         (COMPLEX
 (%%COMPLEX/
 (%%MAKE-COMPLEX N1 0)
                                         N2]
           (COMPLEX
 (CTYPECASE N2 (INTEGER (%%COMPLEX/
 N1 (%%MAKE-COMPLEX N2 0)))
                           (FLOAT (%%COMPLEX/
 N1 (%%MAKE-COMPLEX N2 0.0)))
                           (RATIO (%%/
 (CL:*
 (DENOMINATOR
 N2)
                                             N1)
                                       (NUMERATOR
 N2)))
                           (COMPLEX
 (%%COMPLEX/
 N1 N2])

(1+

  [LAMBDA (X)
                                                (* kbr: "10-Apr-86 23:50")

    (+
 X 1])

(1-

  [LAMBDA (X)
                                                (* kbr: "10-Apr-86 23:50")

    (-
 X 1])
)

(PUTPROPS + DMACRO
 (DEFMACRO (&REST
 NUMBERS) (COND ((NULL NUMBERS)
                                                    0)
                                                   (T (BQUOTE (PLUS (\., NUMBERS))))) )
)

(PUTPROPS - DMACRO
 (DEFMACRO (NUMBER
 &REST NUMBERS) (COND
                                                     ((NULL NUMBERS)
                                                      (BQUOTE (DIFFERENCE 0 (\, NUMBER))))
                                                     (T (for X in NUMBERS do
                                                             (SETQ NUMBER (BQUOTE (DIFFERENCE
                                                                                   (\, NUMBER)
                                                                                   (\, X))))
                                                             finally
                                                             (RETURN NUMBER)))) )
)

(PUTPROPS CL:* DMACRO
 (DEFMACRO (&REST
 NUMBERS) (COND ((NULL NUMBERS)
                                                       1)
                                                      (T (BQUOTE (TIMES (\., NUMBERS))))) )
)

(PUTPROPS / DMACRO
 (DEFMACRO (NUMBER
 &REST NUMBERS) (COND
                                                     ((NULL NUMBERS)
                                                      (BQUOTE (%%/ 1 (\, NUMBER))))
                                                     (T (for X in NUMBERS do
                                                             (SETQ NUMBER (BQUOTE (%%/ (\, NUMBER)
                                                                                       (\, X))))
                                                             finally
                                                             (RETURN NUMBER)))) )
)

(PUTPROPS 1+ DMACRO
 (DEFMACRO (X
 ) (BQUOTE (PLUS (\, X)
                                                 1)) )
)

(PUTPROPS 1- DMACRO
 (DEFMACRO (X
 ) (BQUOTE (DIFFERENCE (\, X)
                                                  1)) )
)



(* "CONJUGATE implemented in section 2.1.4 above.")


(DEFINEQ

(CL:GCD

  (CL:LAMBDA (&OPTIONAL (INTEGER1 0)
                    (INTEGER2 0)
                    &REST INTEGERS)
                          (* kbr: " 8-Apr-86 20:34")

          
          (* CL:GCD -- gcd of an arbitrary number of integers.

          Since the probability is >.6 that the CL:GCD of two numbers is 1, it is worth 

          to time to check for CL:GCD=1 and quit if so.

          However, in this case some arguments may never be type-checked.

          *)

                                                             (* Returns the greatest common divisor 

                                                             of zero or more integers *)

         (CL:DO* ((RES (%%GCD
 INTEGER1 INTEGER2)
                       (%%GCD
 RES (CAR INTEGERS)))
                  (INTEGERS INTEGERS (CDR INTEGERS)))
                ((OR (NULL INTEGERS)
                     (=
 RES 1))
                 RES))))

(%%GCD

  [CL:LAMBDA (U V)
                                           (* kbr: " 8-Apr-86 16:42")

          
          (* %%GCD -- Gcd of two integers, no type checking.

          Rational routines should call this, not CL:GCD, to save overhead.

          Timings show this routine to be faster WITHOUT

          ((ZEROP V) U) . *)


         (LET ((U (ABS U))
               (V (ABS V)))
              (COND
                 ((ZEROP U)
                  V)
                 ((OR (=
 1 V)
                      (=
 1 U))
                  1)
                 (T (CL:DO* ([K (CL:DO ((K 0 (1+
 K)))
                                       ((OR (ODDP
 U)
                                            (ODDP
 V))
                                        K)
                                       (PROGN (SETQ U (ASH
 U -1))
                                              (SETQ V (ASH
 V -1]
                             (TEE (CL:IF (ODDP
 U)
                                         (-
 V)
                                         (ASH
 U -1))
                                  (-
 U V)))
                           ((ZEROP TEE)
                            (ASH
 U K))
                           (CL:DO NIL ((ODDP
 TEE))
                                  (SETQ TEE (ASH
 TEE -1)))
                           (CL:IF (PLUSP
 TEE)
                                  (SETQ U TEE)
                                  (SETQ V (-
 TEE])

(LCM

  (CL:LAMBDA (ARG1 &REST ARGS)
          
          (* LCM -- least common multiple. At least one argument is required.

          We must quit when LCM=0 is computed to avoid division by zero.

          In this case, some arguments may never be type-checked.

          Timings show time is saved by avoiding division when CL:GCD=1.

          *)

                                                             (* Returns the least common multiple 

                                                             of one or more integers.

                                                             *)

         (CL:DO* ((ARG NIL (CAR ARGS))
                  (CL:GCD
 NIL (%%GCD
 ARG RES))
                  [RES ARG1 (CL:*
 ARG (CL:IF (=
 CL:GCD 1)
                                             RES
                                             (/
 RES CL:GCD]
                  (ARGS ARGS (CDR ARGS)))
                ((OR (NULL ARGS)
                     (ZEROP RES))
                 RES))))
)



(* "Section 12.6 Type Conversions and Component Extractions on Numbers.")


(* * "LLFLOAT replacements.  LLFLOAT ufns seem OK once we modify \FLOAT appropriately.")





(* "NUMERATOR and DENOMINATOR implemented in section 2.1.2 above.")


(DEFINEQ

(CL:FLOOR

  [CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1))
          
          (* If the numbers do not divide exactly and the result of

          (/ number divisor) would be negative then decrement the quotient and augment 

          the remainder by the divisor. *)

                                                             (* Returns the greatest integer not 

                                                             greater than number, or 

                                                             number/divisor. The second returned 

                                                             value is (mod number divisor)%.

                                                             *)

         (MULTIPLE-VALUE-BIND (TRU REM)
                (TRUNCATE
 NUMBER DIVISOR)
                (CL:IF (AND (NOT (ZEROP REM))
                            (CL:IF (MINUSP DIVISOR)
                                   (PLUSP
 NUMBER)
                                   (MINUSP NUMBER)))
                       (VALUES (1-
 TRU)
                              (+
 REM DIVISOR))
                       (VALUES TRU REM])

(TRUNCATE

  [CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1))
                  (* lmm "27-Jun-86 22:39")

                                                             (* Returns number (or number/divisor) 

                                                             as an integer, rounded toward 0.0 The 

                                                             second returned value is the 

                                                             remainder. *)

         (PROG (TRU REM)
               [SETQ TRU (COND
                            [(EQ DIVISOR 1)
                             (CTYPECASE NUMBER (INTEGER NUMBER)
                                    (FLOAT (\FIXP.FROM.FLOATP NUMBER))
                                    (RATIO (IQUOTIENT (RATIO-NUMERATOR NUMBER)
                                                  (RATIO-DENOMINATOR NUMBER]
                            (T (CTYPECASE NUMBER [INTEGER (CTYPECASE
                                                           DIVISOR
                                                           (INTEGER (IQUOTIENT NUMBER DIVISOR))
                                                           (FLOAT (FQUOTIENT NUMBER DIVISOR))
                                                           (RATIO (RETURN (TRUNCATE
 (/
 NUMBER DIVISOR
                                                                                       ]
                                      [FLOAT (CTYPECASE DIVISOR ((OR INTEGER FLOAT)
                                                                 (\FIXP.FROM.FLOATP (FQUOTIENT NUMBER 
                                                                                           DIVISOR)))
                                                    (RATIO (RETURN (TRUNCATE
 (/
 NUMBER DIVISOR]
                                      (RATIO (RETURN (TRUNCATE
 (/
 NUMBER DIVISOR]
               (SETQ REM (-
 NUMBER (CL:*
 TRU DIVISOR)))
               (RETURN (VALUES TRU REM])

(CEILING

  [CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1))
          
          (* If the numbers do not divide exactly and the result of

          (/ number divisor) would be positive then increment the quotient and decrement 

          the remainder by the divisor. *)

                                                             (* Returns the smallest integer not 

                                                             less than number, or number/divisor.

                                                             The second returned value is the 

                                                             remainder. *)

         (MULTIPLE-VALUE-BIND (TRU REM)
                (TRUNCATE
 NUMBER DIVISOR)
                (CL:IF (AND (NOT (ZEROP REM))
                            (CL:IF (MINUSP DIVISOR)
                                   (MINUSP NUMBER)
                                   (PLUSP
 NUMBER)))
                       (VALUES (+
 TRU 1)
                              (-
 REM DIVISOR))
                       (VALUES TRU REM])

(ROUND

  [CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1 DIVP)
                    &AUX THRESH)                             (* Rounds number (or number/divisor) 

                                                             to nearest integer. The second 

                                                             returned value is the remainder.

                                                             *)

         (MULTIPLE-VALUE-BIND (TRU REM)
                (TRUNCATE
 NUMBER DIVISOR)
                (CL:IF DIVP (SETQ THRESH (/
 (ABS DIVISOR)
                                            2))
                       (SETQ THRESH .5))
                (COND
                   [(OR (>
 REM THRESH)
                        (AND (=
 REM THRESH)
                             (ODDP
 TRU)))
                    (CL:IF (MINUSP DIVISOR)
                           (VALUES (-
 TRU 1)
                                  (+
 REM DIVISOR))
                           (VALUES (+
 TRU 1)
                                  (-
 REM DIVISOR]
                   [[LET ((-THRESH (-
 THRESH)))
                         (OR (<
 REM -THRESH)
                             (AND (=
 REM -THRESH)
                                  (ODDP
 TRU]
                    (CL:IF (MINUSP DIVISOR)
                           (VALUES (+
 TRU 1)
                                  (-
 REM DIVISOR))
                           (VALUES (-
 TRU 1)
                                  (+
 REM DIVISOR]
                   (T (VALUES TRU REM])

(CL:MOD

  (CL:LAMBDA (NUMBER DIVISOR)                                (* Returns second result of CL:FLOOR.

                                                             *)

         (LET ((REM
 (REM
 NUMBER DIVISOR)))
              (CL:IF (AND (NOT (ZEROP REM))
                          (CL:IF (MINUSP DIVISOR)
                                 (PLUSP
 NUMBER)
                                 (MINUSP NUMBER)))
                     (+
 REM DIVISOR)
                     REM))))

(REM

  (CL:LAMBDA (NUMBER DIVISOR)                                (* Returns second result of TRUNCATE.

                                                             *)

         (MULTIPLE-VALUE-BIND (TRU REM)
                (TRUNCATE
 NUMBER DIVISOR)
                (CL:DECLARE (IGNORE TRU))
                REM)))

(FFLOOR

  (CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1))                  (* Same as CL:FLOOR, but returns first 

                                                             value as a float. *)

         (MULTIPLE-VALUE-BIND (FLR REM)
                (CL:FLOOR
 NUMBER DIVISOR)
                (VALUES (FLOAT FLR)
                       REM))))

(FCEILING

  (CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1))                  (* Same as CEILING, but returns first 

                                                             value as a float. *)

         (MULTIPLE-VALUE-BIND (CEI REM)
                (CEILING
 NUMBER DIVISOR)
                (VALUES (FLOAT CEI)
                       REM))))

(FTRUNCATE

  (CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1))                  (* Same as TRUNCATE, but returns first 

                                                             value as a float. *)

         (MULTIPLE-VALUE-BIND (TRU REM)
                (TRUNCATE
 NUMBER DIVISOR)
                (VALUES (FLOAT TRU)
                       REM))))

(FROUND

  (CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1))                  (* Same as ROUND, but returns first 

                                                             value as a float. *)

         (MULTIPLE-VALUE-BIND (ROU REM)
                (ROUND
 NUMBER DIVISOR)
                (VALUES (FLOAT ROU)
                       REM))))
)



(* "Page 218 functions.")


(DEFINEQ

(DECODE-FLOAT

  [CL:LAMBDA (F)
                                             (* kbr: " 7-Apr-86 20:48")

         (VALUES (create
 FLOATP
                        SIGNBIT _ (fetch
 (FLOATP SIGNBIT) of
 F)
                        EXPONENT _ (SUB1 \EXPONENT.BIAS)
                        HIFRACTION _ (fetch
 (FLOATP HIFRACTION) of
 F)
                        LOFRACTION _ (fetch
 (FLOATP LOFRACTION) of
 F))
                (IDIFFERENCE (fetch
 (FLOATP EXPONENT) of
 F)
                       (SUB1 \EXPONENT.BIAS))
                (COND
                   ((EQ (fetch
 (FLOATP SIGNBIT) of
 F)
                        0)
                    1.0)
                   (T -1.0])

(SCALE-FLOAT

  [LAMBDA (FLOAT INTEGER)
                                    (* kbr: " 9-May-86 00:15")

                                                             (* \MAKEFLOAT knows how to handle 

                                                             underflow and overflow possibilities.

                                                             *)

    (SETQ FLOAT (\DTEST FLOAT (QUOTE FLOATP)))
    (\MAKEFLOAT (fetch
 (FLOATP SIGNBIT) of
 FLOAT)
           (IPLUS (fetch
 (FLOATP EXPONENT) of
 FLOAT)
                  INTEGER 8)
           (IPLUS \HIDDENBIT (fetch
 (FLOATP HIFRACTION) of
 FLOAT))
           (fetch
 (FLOATP LOFRACTION) of
 FLOAT)
           T])

(FLOAT-RADIX

  (CL:LAMBDA (F)
         (CL:DECLARE (IGNORE F))
         2))

(FLOAT-SIGN

  (CL:LAMBDA (FLOAT1 &OPTIONAL (FLOAT2 (FLOAT 1 FLOAT1)))    (* Part 12.5 of the laser edition *)

         (CL:IF (EQ (MINUSP FLOAT1)
                    (MINUSP FLOAT2))
                FLOAT2
                (-
 FLOAT2))))

(FLOAT-DIGITS

  [CL:LAMBDA (F)
                                             (* kbr: "11-Apr-86 00:03")

         (TYPECASE F (SINGLE-FLOAT 23)
                (T (CL:ERROR "Float-digits: ~A not a float" F])

(FLOAT-PRECISION

  (CL:LAMBDA (F)
         (CL:IF (ZEROP F)
                0
                (FLOAT-DIGITS
 F))))

(INTEGER-DECODE-FLOAT

  [CL:LAMBDA (X)
         (LET ((PRECISION (FLOAT-PRECISION
 X)))
              (MULTIPLE-VALUE-BIND (F E S)
                     (DECODE-FLOAT
 X)
                     (VALUES (TRUNCATE
 (SCALE-FLOAT
 F PRECISION))
                            (-
 E PRECISION)
                            S])
)



(* "EXPT COMPLEX REALPART and IMAGPART are defined by CMLFLOAT.")





(* "Section 12.3 Comparisons on Numbers.")


(DEFINEQ

(%%=

  [LAMBDA (X Y)
                                              (* lmm "27-Jun-86 23:37")

                                                             (* %%= does coercion when checking 

                                                             numbers for equality.

                                                             Page 196 of silver book.

                                                             *)

    (\CALLME (QUOTE =))
    (OR (EQL X Y)
        (CTYPECASE X (INTEGER (CTYPECASE Y (FLOAT (FEQP X Y))
                                     [COMPLEX
 (AND (%%=
 0 (COMPLEX-IMAGPART Y))
                                                   (%%=
 X (COMPLEX-REALPART Y]
                                     (NUMBER NIL)))
               [RATIO (CTYPECASE Y [RATIO (AND (EQL (RATIO-NUMERATOR X)
                                                    (RATIO-NUMERATOR Y))
                                               (EQL (RATIO-DENOMINATOR X)
                                                    (RATIO-DENOMINATOR Y]
                             (FLOAT (EQL (FLOAT X)
                                         Y))
                             (INTEGER NIL)
                             (COMPLEX
 (AND (%%=
 (COMPLEX-IMAGPART Y)
                                                0)
                                           (%%=
 X (COMPLEX-REALPART Y]
               [FLOAT (CTYPECASE Y (FLOAT                    (* EQL failed)

                                          NIL)
                             ((OR INTEGER RATIO)
                              (FEQP X Y))
                             (COMPLEX
 (AND (%%=
 (COMPLEX-IMAGPART Y)
                                                0)
                                           (%%=
 X (COMPLEX-REALPART Y]
               (COMPLEX
 (CTYPECASE Y [COMPLEX
 (AND (%%=
 (COMPLEX-REALPART X)
                                                        (COMPLEX-REALPART Y))
                                                   (%%=
 (COMPLEX-IMAGPART X)
                                                        (COMPLEX-IMAGPART Y]
                               (NUMBER (AND (%%=
 (COMPLEX-IMAGPART X)
                                                 0)
                                            (%%=
 (COMPLEX-REALPART X)
                                                 Y])

(%%>

  [LAMBDA (X Y)
                                              (* lmm "20-Jun-86 07:16")

    (\CALLME (QUOTE >))
    (CTYPECASE X [INTEGER (CTYPECASE Y (INTEGER (IGREATERP X Y))
                                 (FLOAT (FGREATERP X Y))
                                 (RATIO (IGREATERP (CL:*
 (DENOMINATOR
 Y)
                                                         X)
                                               (NUMERATOR
 Y]
           [FLOAT (CTYPECASE Y ((OR INTEGER FLOAT)
                                (FGREATERP X Y))
                         (RATIO (FGREATERP (CL:*
 (DENOMINATOR
 Y)
                                                 X)
                                       (NUMERATOR
 Y]
           (RATIO (CTYPECASE Y (INTEGER (IGREATERP (NUMERATOR
 X)
                                               (CL:*
 (DENOMINATOR
 X)
                                                     Y)))
                         (FLOAT (FGREATERP (FQUOTIENT (NUMERATOR
 X)
                                                  (DENOMINATOR
 X))
                                       Y))
                         (RATIO (IGREATERP (CL:*
 (NUMERATOR
 X)
                                                 (DENOMINATOR
 Y))
                                       (CL:*
 (NUMERATOR
 Y)
                                             (DENOMINATOR
 X])
)
(DEFINEQ

(=

  (CL:LAMBDA (NUMBER &REST MORE-NUMBERS)
                     (* lmm "16-Jul-85 16:51")

         (for
 X in
 MORE-NUMBERS always
 (%%=
 NUMBER X))))

(%%=

  [LAMBDA (X Y)
                                              (* lmm "27-Jun-86 23:37")

                                                             (* %%= does coercion when checking 

                                                             numbers for equality.

                                                             Page 196 of silver book.

                                                             *)

    (\CALLME (QUOTE =))
    (OR (EQL X Y)
        (CTYPECASE X (INTEGER (CTYPECASE Y (FLOAT (FEQP X Y))
                                     [COMPLEX
 (AND (%%=
 0 (COMPLEX-IMAGPART Y))
                                                   (%%=
 X (COMPLEX-REALPART Y]
                                     (NUMBER NIL)))
               [RATIO (CTYPECASE Y [RATIO (AND (EQL (RATIO-NUMERATOR X)
                                                    (RATIO-NUMERATOR Y))
                                               (EQL (RATIO-DENOMINATOR X)
                                                    (RATIO-DENOMINATOR Y]
                             (FLOAT (EQL (FLOAT X)
                                         Y))
                             (INTEGER NIL)
                             (COMPLEX
 (AND (%%=
 (COMPLEX-IMAGPART Y)
                                                0)
                                           (%%=
 X (COMPLEX-REALPART Y]
               [FLOAT (CTYPECASE Y (FLOAT                    (* EQL failed)

                                          NIL)
                             ((OR INTEGER RATIO)
                              (FEQP X Y))
                             (COMPLEX
 (AND (%%=
 (COMPLEX-IMAGPART Y)
                                                0)
                                           (%%=
 X (COMPLEX-REALPART Y]
               (COMPLEX
 (CTYPECASE Y [COMPLEX
 (AND (%%=
 (COMPLEX-REALPART X)
                                                        (COMPLEX-REALPART Y))
                                                   (%%=
 (COMPLEX-IMAGPART X)
                                                        (COMPLEX-IMAGPART Y]
                               (NUMBER (AND (%%=
 (COMPLEX-IMAGPART X)
                                                 0)
                                            (%%=
 (COMPLEX-REALPART X)
                                                 Y])

(/=

  [CL:LAMBDA (&REST NUMBERS)
                                 (* lmm "16-Jul-85 16:56")

         (for
 X on
 NUMBERS always
 (for
 Y in
 (CDR X) always
 (NOT (=
 (CAR X)
                                                                   Y])

(<

  [CL:LAMBDA (&REST MORE-NUMBERS)
                            (* lmm "19-Jun-86 17:13")

         (for
 X on
 MORE-NUMBERS while
 (CDR X) always
 (>
 (CADR X)
                                                        (CAR X])

(>

  [CL:LAMBDA (&REST MORE-NUMBERS)
                            (* lmm "19-Jun-86 17:15")

         (for
 X on
 MORE-NUMBERS while
 (CDR X) always
 (%%>
 (CAR X)
                                                          (CADR X])

(<=

  [CL:LAMBDA (&REST MORE-NUMBERS)
                            (* lmm "16-Jul-85 17:18")

         (for
 X on
 MORE-NUMBERS while
 (CDR X) always
 (LEQ (CAR X)
                                                          (CADR X])

(>=

  [CL:LAMBDA (&REST MORE-NUMBERS)
                            (* lmm "19-Jun-86 16:58")

         (for
 X on
 MORE-NUMBERS while
 (CDR X) always
 (NOT (<
 (CAR X)
                                                           (CADR X])
)

(PUTPROPS = DMACRO
 
          (DEFMACRO (N
 &REST NS) (COND
                                  ((CDR NS)
                                   (LET
                                    ((NNAME (GENSYM)))
                                    (BQUOTE
                                     (LET (((\, NNAME)
                                            (\, N)))
                                          (AND (\,@ (for X in NS collect (BQUOTE (%%= (\, NNAME)
                                                                                      (\, X))))))))))
                                  (T (BQUOTE (%%= (\, N)
                                                  (\, (CAR NS)))))) )
)

(PUTPROPS /= DMACRO
 
          (DEFMACRO (N
 &REST NS) (COND
                                  (NS
                                   (COND
                                    ((CDR NS)
                                     (LET
                                      ((VARS (for X in (CONS N NS)
                                                  collect
                                                  (LIST (GENSYM (QUOTE /=))
                                                        X))))
                                      (BQUOTE
                                       (LET
                                        (\, VARS)
                                        (AND
                                         (\,@
                                          (for X on VARS join
                                               (for Y on (CDR VARS)
                                                    collect
                                                    (BQUOTE (NOT (= (\, (CAAR X))
                                                                    (\, (CAAR Y)))))))))))))
                                    (T (BQUOTE (NOT (= %, N %, (CAR NS)))))))
                                  (T T)) )
)

(PUTPROPS < DMACRO
 
          (DEFMACRO (N
 &REST NS) (COND
                                  ((NULL NS)
                                   T)
                                  ((CDR NS)
                                   (LET
                                    ((VARS (FOR X IN (CONS N NS)
                                                COLLECT
                                                (LIST (GENSYM (QUOTE /=))
                                                      X))))
                                    (BQUOTE
                                     ((OPENLAMBDA
                                       (\, (MAPCAR VARS (QUOTE CAR)))
                                       (AND (\,@ (for X on VARS while (CDR X)
                                                      collect
                                                      (BQUOTE (LESSP (\, (CAAR X))
                                                                     (\, (CAADR X))))))))
                                      (\,@ (MAPCAR VARS (QUOTE CADR)))))))
                                  (T (BQUOTE (LESSP (\, N)
                                                    (\, (CAR NS)))))) )
)

(PUTPROPS > DMACRO
 
          (DEFMACRO (N
 &REST NS) (COND
                                  ((NULL NS)
                                   T)
                                  ((CDR NS)
                                   (LET
                                    ((VARS (FOR X IN (CONS N NS)
                                                COLLECT
                                                (LIST (GENSYM (QUOTE /=))
                                                      X))))
                                    (BQUOTE
                                     ((OPENLAMBDA
                                       (\, (MAPCAR VARS (QUOTE CAR)))
                                       (AND (\,@ (for X on VARS while (CDR X)
                                                      collect
                                                      (BQUOTE (GREATERP (\, (CAAR X))
                                                                     (\, (CAADR X))))))))
                                      (\,@ (MAPCAR VARS (QUOTE CADR)))))))
                                  (T (BQUOTE (GREATERP (\, N)
                                                    (\, (CAR NS)))))) )
)

(PUTPROPS <= DMACRO
 
          (DEFMACRO (N
 &REST NS) (COND
                                  ((NULL NS)
                                   T)
                                  ((CDR NS)
                                   (LET
                                    ((VARS (FOR X IN (CONS N NS)
                                                COLLECT
                                                (LIST (GENSYM (QUOTE /=))
                                                      X))))
                                    (BQUOTE
                                     ((OPENLAMBDA
                                       (\, (MAPCAR VARS (QUOTE CAR)))
                                       (AND (\,@ (for X on VARS while (CDR X)
                                                      collect
                                                      (BQUOTE (LEQ (\, (CAAR X))
                                                                   (\, (CAADR X))))))))
                                      (\,@ (MAPCAR VARS (QUOTE CADR)))))))
                                  (T (BQUOTE (LEQ (\, N)
                                                  (\, (CAR NS)))))) )
)

(PUTPROPS >= DMACRO
 
          (DEFMACRO (N
 &REST NS) (COND
                                  ((NULL NS)
                                   T)
                                  ((CDR NS)
                                   (LET
                                    ((VARS (FOR X IN (CONS N NS)
                                                COLLECT
                                                (LIST (GENSYM (QUOTE >=))
                                                      X))))
                                    (BQUOTE
                                     ((OPENLAMBDA
                                       (\, (MAPCAR VARS (QUOTE CAR)))
                                       (AND
                                        (\,@ (for X on VARS while (CDR X)
                                                  collect
                                                  (BQUOTE (NOT (< (\, (CAAR X))
                                                                (\, (CAADR X)))))))))
                                      (\,@ (MAPCAR VARS (FUNCTION CADR)))))))
                                  (T (BQUOTE (GEQ (\, N)
                                                  (\, (CAR NS)))))) )
)



(* "MAX and MIN are OK")





(* "new general arithmetic UFNs which know about ratio and complex")





(* 
"NOTE: %%/ CAN NOT COMPILE INTO THE EXISTING QUOTIENT OPCODE.  This is because %%/ is supposed to produce a rational when numerator is not evenly divisible by denominator.  Therefore, there is no MACRO for %%/ below."
)



(PUTPROPS %%+ DOPVAL
 (2 PLUS2))

(PUTPROPS %%- DOPVAL
 (2 DIFFERENCE))

(PUTPROPS %%* DOPVAL
 (2 TIMES2))

(PUTPROPS %%> DOPVAL
 (2 GREATERP))
(DEFINEQ

(%%+

  [LAMBDA (N1 N2)
                                            (* lmm "19-Jun-86 15:39")

    (\CALLME (QUOTE +))                                      (* UFN for + Microcode generally 

                                                             handles the case of two args both 

                                                             FIXPs)

    (PROG NIL
      LOOP
          (RETURN (CTYPECASE N1 [INTEGER (CTYPECASE N2 (INTEGER (IPLUS N1 N2))
                                                (FLOAT (FPLUS N1 N2))
                                                (RATIO (%%RATIO-INTEGER+
 N2 N1))
                                                (COMPLEX
 (%%COMPLEX+
 (%%MAKE-COMPLEX N1 0)
                                                                N2]
                         [FLOAT (CTYPECASE N2 ((OR INTEGER FLOAT)
                                               (FPLUS N1 N2))
                                       [RATIO (FPLUS N1 (FQUOTIENT (NUMERATOR
 N2)
                                                               (DENOMINATOR
 N2]
                                       (COMPLEX
 (%%COMPLEX+
 (%%MAKE-COMPLEX N1 0.0)
                                                       N2]
                         [RATIO (CTYPECASE N2 (INTEGER (%%RATIO-INTEGER+
 N1 N2))
                                       (FLOAT (FPLUS (FQUOTIENT (NUMERATOR
 N1)
                                                            (DENOMINATOR
 N1))
                                                     N2))
                                       (RATIO (%%RATIO+
 N1 N2))
                                       (COMPLEX
 (%%COMPLEX+
 (%%MAKE-COMPLEX N1 0)
                                                       N2]
                         (COMPLEX
 (CTYPECASE N2 (INTEGER (%%COMPLEX+
 N1 (%%MAKE-COMPLEX N2 0)))
                                         (SINGLE-FLOAT (%%COMPLEX+
 N1 (%%MAKE-COMPLEX N2 0.0)))
                                         (RATIO (%%COMPLEX+
 N1 (%%MAKE-COMPLEX N2 0)))
                                         (COMPLEX
 (%%COMPLEX+
 N1 N2])

(%%-

  [LAMBDA (N1 N2)
                                            (* lmm "19-Jun-86 15:41")

    (\CALLME (QUOTE -
))                                      (* UFN for -

                                                             Microcode generally handles the case 

                                                             of two args both FIXPs)

    (CTYPECASE N1 [INTEGER (CTYPECASE N2 (INTEGER (IDIFFERENCE N1 N2))
                                  (SINGLE-FLOAT (FDIFFERENCE N1 N2))
                                  (RATIO (%%RATIO-
 (%%MAKE-RATIO N1 1)
                                                N2))
                                  (COMPLEX
 (%%COMPLEX-
 (%%MAKE-COMPLEX N1 0)
                                                  N2]
           [FLOAT (CTYPECASE N2 ((OR INTEGER SINGLE-FLOAT)
                                 (FDIFFERENCE N1 N2))
                         [RATIO (FDIFFERENCE N1 (FQUOTIENT (NUMERATOR
 N2)
                                                       (DENOMINATOR
 N2]
                         (COMPLEX
 (%%COMPLEX-
 (%%MAKE-COMPLEX N1 0.0)
                                         N2]
           [RATIO (CTYPECASE N2 (INTEGER (%%RATIO-INTEGER-
 N1 N2))
                         (FLOAT (FDIFFERENCE (FQUOTIENT (NUMERATOR
 N1)
                                                    (DENOMINATOR
 N1))
                                       N2))
                         (RATIO (%%RATIO-
 N1 N2))
                         (COMPLEX
 (%%COMPLEX-
 (%%MAKE-COMPLEX N1 0)
                                         N2]
           (COMPLEX
 (CTYPECASE N2 (INTEGER (%%COMPLEX-
 N1 (%%MAKE-COMPLEX N2 0)))
                           (FLOAT (%%COMPLEX-
 N1 (%%MAKE-COMPLEX N2 0.0)))
                           (RATIO (%%COMPLEX-
 N1 (%%MAKE-COMPLEX N2 0)))
                           (COMPLEX
 (%%COMPLEX-
 N1 N2])

(%%*

  [LAMBDA (N1 N2)
                                            (* lmm "19-Jun-86 15:42")

    (\CALLME (QUOTE CL:*))                                   (* UFN for CL:* Microcode generally 

                                                             handles the case of two args both 

                                                             FIXPs)

    (CTYPECASE N2 [INTEGER (CTYPECASE N1 (INTEGER (ITIMES N1 N2))
                                  (FLOAT (FTIMES N1 N2))
                                  (RATIO (%%RATIO-INTEGER*
 N1 N2))
                                  (COMPLEX
 (%%COMPLEX*
 N1 (%%MAKE-COMPLEX N2 0]
           [FLOAT (CTYPECASE N1 ((OR INTEGER FLOAT)
                                 (FTIMES N1 N2))
                         (RATIO (FTIMES (FQUOTIENT (NUMERATOR
 N1)
                                               (DENOMINATOR
 N1))
                                       N2))
                         (COMPLEX
 (%%COMPLEX*
 N1 (%%MAKE-COMPLEX N2 0.0]
           [RATIO (CTYPECASE N1 (INTEGER (%%RATIO-INTEGER*
 N2 N1))
                         [FLOAT (FTIMES N1 (FQUOTIENT (NUMERATOR
 N2)
                                                  (DENOMINATOR
 N2]
                         (RATIO (%%RATIO*
 N2 N1))
                         (COMPLEX
 (%%COMPLEX*
 N1 (%%MAKE-COMPLEX N2 0]
           (COMPLEX
 (CTYPECASE N1 ((OR INTEGER RATIO)
                                   (%%COMPLEX*
 (%%MAKE-COMPLEX N1 0)
                                          N2))
                           (FLOAT (%%COMPLEX*
 (%%MAKE-COMPLEX N1 0.0)
                                         N2))
                           (COMPLEX
 (%%COMPLEX*
 N1 N2])

(%%/

  [LAMBDA (N1 N2)
                                            (* lmm "19-Jun-86 15:43")

    (\CALLME (QUOTE /))                                      (* UFN for / Microcode generally 

                                                             handles the case of two args both 

                                                             FIXPs)

    (CTYPECASE N1 [INTEGER (CTYPECASE N2 [INTEGER (COND
                                                     ((EVENP
 N1 N2)
                                                      (IQUOTIENT N1 N2))
                                                     (T (%%BUILD-RATIO
 N1 N2]
                                  (FLOAT (FQUOTIENT N1 N2))
                                  (RATIO (%%/
 (CL:*
 (DENOMINATOR
 N2)
                                                    N1)
                                              (NUMERATOR
 N2)))
                                  (COMPLEX
 (%%COMPLEX/
 (%%MAKE-COMPLEX N1 0)
                                                  N2]
           [FLOAT (CTYPECASE N2 ((OR INTEGER FLOAT)
                                 (FQUOTIENT N1 N2))
                         (RATIO (%%/
 (CL:*
 (DENOMINATOR
 N2)
                                           N1)
                                     (NUMERATOR
 N2)))
                         (COMPLEX
 (%%COMPLEX/
 (%%MAKE-COMPLEX N1 0.0)
                                         N2]
           [RATIO (CTYPECASE N2 (INTEGER (%%BUILD-RATIO
 (NUMERATOR
 N1)
                                                (CL:*
 (DENOMINATOR
 N1)
                                                      N2)))
                         (FLOAT (FQUOTIENT N1 N2))
                         (RATIO (%%RATIO/
 N1 N2))
                         (COMPLEX
 (%%COMPLEX/
 (%%MAKE-COMPLEX N1 0)
                                         N2]
           (COMPLEX
 (CTYPECASE N2 (INTEGER (%%COMPLEX/
 N1 (%%MAKE-COMPLEX N2 0)))
                           (FLOAT (%%COMPLEX/
 N1 (%%MAKE-COMPLEX N2 0.0)))
                           (RATIO (%%/
 (CL:*
 (DENOMINATOR
 N2)
                                             N1)
                                       (NUMERATOR
 N2)))
                           (COMPLEX
 (%%COMPLEX/
 N1 N2])
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(\SETUFNENTRY (CAR (\FINDOP (QUOTE PLUS2)))
       (QUOTE %%+)
       2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE DIFFERENCE)))
       (QUOTE %%-)
       2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE TIMES2)))
       (QUOTE %%*)
       2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE GREATERP)))
       (QUOTE %%>)
       2 0)
)



(* "Section 12.7 Logical Operations on Numbers.")





(* "Page 221 functions.  LOGAND LOGXOR are OK.")


(DEFINEQ

(LOGIOR

  [LAMBDA N
                                                  (* lmm "19-Jun-86 16:22")

                                                             (* 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])

(LOGEQV

  (CL:LAMBDA (&REST INTEGERS)
                                (* lmm " 5-Sep-85 02:19")

         (COND
            (INTEGERS (CL:DO* [(RESULT (pop
 INTEGERS)
                                      (LOGNOT (LOGXOR RESULT (pop
 INTEGERS]
                             ((NULL INTEGERS)
                              RESULT)))
            (T -1))))

(LOGNAND

  (CL:LAMBDA (INTEGER1 INTEGER2)
                             (* kbr: "31-Aug-85 21:00")

         (LOGNOT (LOGAND INTEGER1 INTEGER2))))

(LOGNOR

  (CL:LAMBDA (INTEGER1 INTEGER2)
                             (* kbr: "31-Aug-85 21:00")

         (LOGNOT (LOGOR INTEGER1 INTEGER2))))

(LOGANDC1

  (CL:LAMBDA (INTEGER1 INTEGER2)
                             (* kbr: "31-Aug-85 21:00")

         (LOGAND (LOGNOT INTEGER1)
                INTEGER2)))

(LOGANDC2

  (CL:LAMBDA (INTEGER1 INTEGER2)
                             (* kbr: "31-Aug-85 21:01")

         (LOGAND INTEGER1 (LOGNOT INTEGER2))))

(LOGORC1

  (CL:LAMBDA (INTEGER1 INTEGER2)
                             (* kbr: "31-Aug-85 21:01")

         (LOGOR (LOGNOT INTEGER1)
                INTEGER2)))

(LOGORC2

  (CL:LAMBDA (INTEGER1 INTEGER2)
                             (* kbr: "31-Aug-85 21:01")

         (LOGOR INTEGER1 (LOGNOT INTEGER2))))
)



(* "Page 222.0 BOOLE and constants.")


(DEFINEQ

(BOOLE

  (CL:LAMBDA (OP INTEGER1 INTEGER2)
                          (* lmm " 5-Sep-85 02:24")

         (SELECTQ OP
             (0 0)
             (1 -1)
             (2 INTEGER1)
             (3 INTEGER2)
             (4 (LOGNOT INTEGER1))
             (5 (LOGNOT INTEGER2))
             (6 (LOGAND INTEGER1 INTEGER2))
             (7 (LOGIOR
 INTEGER1 INTEGER2))
             (8 (LOGXOR INTEGER1 INTEGER2))
             (9 (LOGEQV
 INTEGER1 INTEGER2))
             (10 (LOGNAND
 INTEGER1 INTEGER2))
             (11 (LOGNOR
 INTEGER1 INTEGER2))
             (12 (LOGANDC1
 INTEGER1 INTEGER2))
             (13 (LOGANDC2
 INTEGER1 INTEGER2))
             (14 (LOGORC1
 INTEGER1 INTEGER2))
             (15 (LOGORC2
 INTEGER1 INTEGER2))
             (CL:ERROR "~S is not of type (mod 16)." OP))))
)
(DEFCONSTANT BOOLE-CLR
 0)

(DEFCONSTANT BOOLE-SET
 1)

(DEFCONSTANT BOOLE-1
 2)

(DEFCONSTANT BOOLE-2
 3)

(DEFCONSTANT BOOLE-C1
 4)

(DEFCONSTANT BOOLE-C2
 5)

(DEFCONSTANT BOOLE-AND
 6)

(DEFCONSTANT BOOLE-IOR
 7)

(DEFCONSTANT BOOLE-XOR
 8)

(DEFCONSTANT BOOLE-EQV
 9)

(DEFCONSTANT BOOLE-NAND
 10)

(DEFCONSTANT BOOLE-NOR
 11)

(DEFCONSTANT BOOLE-ANDC1
 12)

(DEFCONSTANT BOOLE-ANDC2
 13)

(DEFCONSTANT BOOLE-ORC1
 14)

(DEFCONSTANT BOOLE-ORC2
 15)




(* "Remainder of section 12.7 LOGNOT is OK.")


(DEFINEQ

(LOGTEST

  (CL:LAMBDA (INTEGER1 INTEGER2)
                             (* kbr: "31-Aug-85 21:10")

         (NOT (EQ (LOGAND INTEGER1 INTEGER2)
                  0))))

(LOGBITP

  (CL:LAMBDA (INDEX INTEGER)
                                 (* kbr: "31-Aug-85 21:12")

         (EQ (LOADBYTE INTEGER INDEX 1)
             1)))
)
(DEFINEQ

(ASH

  [LAMBDA (X N)
                                              (* lmm "12-Apr-85 07:55")

    (COND
       [(ILEQ N 0)
        (COND
           ((EQ N 0)
            X)
           (T (RSH X (IMINUS N]
       ((EQ X 0)
        0)
       ((IGREATERP N (CONSTANT (INTEGERLENGTH MAX.FIXP)))
        (\BIGNUM.LSH X N))
       (T (FRPTQ N (SETQ X (IPLUS X X)))
          X])
)
(DEFINEQ

(LOGCOUNT

  [CL:LAMBDA (X)
                                             (* kbr: "10-Apr-86 17:38")

                                                             (* Logcount returns the number of bits 

                                                             that are the complement of the sign in 

                                                             the integer argument x.

                                                             *)

                                                             (* If X is negative, then the number 

                                                             of 0 bits is returned, otherwise 

                                                             number of 1 bits is returned.

                                                             *)

         (COND
            ((OR (SMALLP X)
                 (FIXP X))
             (%%LOGCOUNT
 (CL:IF (MINUSP X)
                                (LOGNOT X)
                                X)))
            ((type?
 BIGNUM X)
             (for
 ELEMENT in
 (fetch
 (BIGNUM ELEMENTS) of
 (CL:IF (MINUSP X)
                                                                (LOGNOT X)
                                                                X)) sum
 (%%LOGCOUNT
 ELEMENT)))
            (T (CL:ERROR "Argument not integer, ~A." X])

(%%LOGCOUNT

  [LAMBDA (N)
                                                (* kbr: " 7-Apr-86 21:50")

                                                             (* Returns number of 1 bits in 

                                                             nonnegative integer N.

                                                             *)

    (PROG (CNT)
          (SETQ CNT 0)                                       (* This loop uses a LOGAND trick for 

                                                             extra speed. *)

          (while
 (NOT (EQ N 0)) do
                           (* Change rightmost 1 bit of N to a 0 

                                                             bit. *)

                                   (SETQ N (LOGAND N (1-
 N)))
                                   (SETQ CNT (1+
 CNT)))
          (RETURN CNT])
)
(DEFINEQ

(INTEGER-LENGTH

  [LAMBDA (X)
                                                (* lmm "28-Jun-86 20:33")

    (if
 (<
 X 0)
        then
 (SETQ X (-
 -1 X)))
    (MACROLET [(NBITS.OR.LESS (X N)
                      (BQUOTE (<
 (\, X)
                               (\, (ASH
 1 N]
           (COND
              ((NBITS.OR.LESS X 16)
               (COND
                  ((NBITS.OR.LESS X 8)
                   (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 8)))
                  ((NBITS.OR.LESS X 12)
                   (COND
                      ((NBITS.OR.LESS X 10)
                       (COND
                          ((NBITS.OR.LESS X 9)
                           9)
                          (T 10)))
                      ((NBITS.OR.LESS X 11)
                       11)
                      (T 12)))
                  ((NBITS.OR.LESS X 14)
                   (COND
                      ((NBITS.OR.LESS X 13)
                       13)
                      (T 14)))
                  ((NBITS.OR.LESS X 15)
                   15)
                  (T 16)))
              (T (+
 16 (INTEGER-LENGTH
 (ASH
 X -16])
)



(* "Section 12.8 Byte Manipulations Functions.")





(* "BYTE macro already implemented.  Should be function.")


(DEFINEQ

(BYTE-SIZE

  (CL:LAMBDA (BYTESPEC)
                                      (* kbr: "31-Aug-85 21:15")

         (fetch
 (BYTESPEC BYTESPEC.SIZE) of
 BYTESPEC)))

(BYTE-POSITION

  (CL:LAMBDA (BYTESPEC)
                                      (* lmm "16-Sep-85 13:28")

         (fetch
 (BYTESPEC BYTESPEC.POSITION) of
 BYTESPEC)))
)



(* "LDB macro already implemented.  Should be function.")


(DEFINEQ

(LDB-TEST

  (CL:LAMBDA (BYTESPEC INTEGER)
                              (* kbr: "31-Aug-85 21:21")

         (NOT (EQ (MASK-FIELD
 BYTESPEC INTEGER)
                  0))))

(MASK-FIELD

  (CL:LAMBDA (BYTESPEC INTEGER)
                              (* kbr: "31-Aug-85 21:21")

         (LOGAND (MASK.1'S (fetch
 (BYTESPEC BYTESPEC.POSITION) of
 BYTESPEC)
                        (fetch
 (BYTESPEC BYTESPEC.SIZE) of
 BYTESPEC))
                INTEGER)))
)



(* "DPB macro already implemented.  Should be function.")


(DEFINEQ

(DEPOSIT-FIELD

  (CL:LAMBDA (NEWBYTE BYTESPEC INTEGER)
                      (* kbr: "31-Aug-85 21:23")

         (DEPOSITBYTE NEWBYTE (fetch
 (BYTESPEC BYTESPEC.POSITION) of
 BYTESPEC)
                (fetch
 (BYTESPEC BYTESPEC.SIZE) of
 BYTESPEC)
                INTEGER)))
)



(* 
"Section 12.10, implementation parameters.  The constants in this COMS are exported to the user."
)


(DEFUN **FLOAT**
 (F E) (SCALE-FLOAT (DECODE-FLOAT (FLOAT F))
                              E))

(DEFCONSTANT MOST-POSITIVE-FIXNUM
 65535)

(DEFCONSTANT MOST-NEGATIVE-FIXNUM
 -65536)

(DEFCONSTANT MOST-POSITIVE-SINGLE-FLOAT
 3.402823E38)

(DEFCONSTANT LEAST-POSITIVE-SINGLE-FLOAT
 (**FLOAT** 1 -125) )

(DEFCONSTANT LEAST-NEGATIVE-SINGLE-FLOAT
 (**FLOAT** -1 -125) )

(DEFCONSTANT MOST-NEGATIVE-SINGLE-FLOAT
 -3.402823E38)

(DEFCONSTANT MOST-POSITIVE-SHORT-FLOAT
 MOST-POSITIVE-SINGLE-FLOAT)

(DEFCONSTANT LEAST-POSITIVE-SHORT-FLOAT
 LEAST-POSITIVE-SINGLE-FLOAT)

(DEFCONSTANT LEAST-NEGATIVE-SHORT-FLOAT
 LEAST-NEGATIVE-SINGLE-FLOAT)

(DEFCONSTANT MOST-NEGATIVE-SHORT-FLOAT
 MOST-NEGATIVE-SINGLE-FLOAT)

(DEFCONSTANT MOST-POSITIVE-DOUBLE-FLOAT
 MOST-POSITIVE-SINGLE-FLOAT)

(DEFCONSTANT LEAST-POSITIVE-DOUBLE-FLOAT
 LEAST-POSITIVE-SINGLE-FLOAT)

(DEFCONSTANT LEAST-NEGATIVE-DOUBLE-FLOAT
 LEAST-NEGATIVE-SINGLE-FLOAT)

(DEFCONSTANT MOST-NEGATIVE-DOUBLE-FLOAT
 MOST-NEGATIVE-SINGLE-FLOAT)

(DEFCONSTANT MOST-POSITIVE-LONG-FLOAT
 MOST-POSITIVE-SINGLE-FLOAT)

(DEFCONSTANT LEAST-POSITIVE-LONG-FLOAT
 LEAST-POSITIVE-SINGLE-FLOAT)

(DEFCONSTANT LEAST-NEGATIVE-LONG-FLOAT
 LEAST-NEGATIVE-SINGLE-FLOAT)

(DEFCONSTANT MOST-NEGATIVE-LONG-FLOAT
 MOST-NEGATIVE-SINGLE-FLOAT)




(* 
"EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON)))"
)


(DEFCONSTANT SINGLE-FLOAT-EPSILON
 (**FLOAT** 1 -22) )

(DEFCONSTANT SHORT-FLOAT-EPSILON
 SINGLE-FLOAT-EPSILON)

(DEFCONSTANT DOUBLE-FLOAT-EPSILON
 SINGLE-FLOAT-EPSILON)

(DEFCONSTANT LONG-FLOAT-EPSILON
 SINGLE-FLOAT-EPSILON)




(* 
"NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON)))"
)


(DEFCONSTANT SINGLE-FLOAT-NEGATIVE-EPSILON
 (**FLOAT** 1 -23) )

(DEFCONSTANT SHORT-FLOAT-NEGATIVE-EPSILON
 SINGLE-FLOAT-NEGATIVE-EPSILON)

(DEFCONSTANT DOUBLE-FLOAT-NEGATIVE-EPSILON
 SINGLE-FLOAT-NEGATIVE-EPSILON)

(DEFCONSTANT LONG-FLOAT-NEGATIVE-EPSILON
 SINGLE-FLOAT-NEGATIVE-EPSILON)

(DECLARE: EVAL@COMPILE DONTCOPY 
(FILESLOAD (LOADCOMP)
       LLFLOAT LLBIGNUM)
)

(PUTPROPS CMLARITH FILETYPE
 COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 
          DEPOSIT-FIELD MASK-FIELD LDB-TEST BYTE-POSITION BYTE-SIZE LOGCOUNT LOGBITP LOGTEST BOOLE 
                LOGORC2 LOGORC1 LOGANDC2 LOGANDC1 LOGNOR LOGNAND LOGEQV LOGIOR >= <= > < /= = 
                INTEGER-DECODE-FLOAT FLOAT-PRECISION FLOAT-DIGITS FLOAT-SIGN FLOAT-RADIX DECODE-FLOAT 
                FROUND FTRUNCATE FCEILING FFLOOR REM CL:MOD ROUND CEILING TRUNCATE CL:FLOOR LCM %%GCD 
                CL:GCD / CL:* - + PLUSP ODDP EVENP \PRINT.COMPLEX %%COMPLEX-TIMESI %%COMPLEX-MINUS 
                %%COMPLEX-ABS %%COMPLEX/ %%COMPLEX* %%COMPLEX- %%COMPLEX+ IMAGPART REALPART COMPLEX 
                %%RATIO-INTEGER- %%RATIO-INTEGER+ %%RATIO-INTEGER* %%RATIO-PLUS-DIFFERENCE %%RATIO- 
                %%RATIO+ %%RATIO-TIMES-QUOTIENT %%RATIO/ %%RATIO* %%RATIONALIZE-FLOAT RATIONALIZE 
                RATIONAL %%BUILD-RATIO DENOMINATOR NUMERATOR %%SIGNUM SIGNUM PHASE PRIMEP ISQRT)
)
(PUTPROPS CMLARITH COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (8823 12535 (ISQRT 8833 . 10222) (PRIMEP 10224 . 11119) (PHASE 11121 . 11362) (SIGNUM 
11364 . 12223) (%%SIGNUM 12225 . 12533)) (12700 14319 (\RATIO.DEFPRINT 12710 . 14317)) (14546 25678 (
NUMERATOR 14556 . 14915) (DENOMINATOR 14917 . 15284) (%%BUILD-RATIO 15286 . 16358) (RATIONALP 16360 . 
16521) (RATIONAL 16523 . 17943) (RATIONALIZE 17945 . 18824) (%%RATIONALIZE-FLOAT 18826 . 20146) (
%%RATIO* 20148 . 20784) (%%RATIO/ 20786 . 21288) (%%RATIO-TIMES-QUOTIENT 21290 . 21982) (%%RATIO+ 
21984 . 22409) (%%RATIO- 22411 . 22490) (%%RATIO-PLUS-DIFFERENCE 22492 . 23709) (%%RATIO-INTEGER* 
23711 . 24644) (%%RATIO-INTEGER+ 24646 . 25124) (%%RATIO-INTEGER- 25126 . 25676)) (26148 30727 (
COMPLEX 26158 . 27088) (REALPART 27090 . 27300) (IMAGPART 27302 . 27535) (%%COMPLEX+ 27537 . 27794) (
%%COMPLEX- 27796 . 28056) (%%COMPLEX* 28058 . 28502) (%%COMPLEX/ 28504 . 29242) (%%COMPLEX-ABS 29244
 . 29525) (%%COMPLEX-MINUS 29527 . 29731) (%%COMPLEX-TIMESI 29733 . 30123) (CONJUGATE 30125 . 30410) (
\PRINT.COMPLEX 30412 . 30725)) (30859 31314 (EVENP 30869 . 31021) (ODDP 31023 . 31177) (PLUSP 31179 . 
31312)) (31365 35796 (+ 31375 . 31999) (- 32001 . 32500) (CL:* 32502 . 32934) (/ 32936 . 33224) (%%/ 
33226 . 35550) (1+ 35552 . 35672) (1- 35674 . 35794)) (37945 41452 (CL:GCD 37955 . 38916) (%%GCD 38918
 . 40407) (LCM 40409 . 41450)) (41706 49798 (CL:FLOOR 41716 . 42881) (TRUNCATE 42883 . 44877) (CEILING
 44879 . 45969) (ROUND 45971 . 47537) (CL:MOD 47539 . 48039) (REM 48041 . 48371) (FFLOOR 48373 . 48728
) (FCEILING 48730 . 49085) (FTRUNCATE 49087 . 49445) (FROUND 49447 . 49796)) (49833 52291 (
DECODE-FLOAT 49843 . 50557) (SCALE-FLOAT 50559 . 51283) (FLOAT-RADIX 51285 . 51364) (FLOAT-SIGN 51366
 . 51613) (FLOAT-DIGITS 51615 . 51831) (FLOAT-PRECISION 51833 . 51954) (INTEGER-DECODE-FLOAT 51956 . 
52289)) (52417 56242 (%%= 52427 . 54837) (%%> 54839 . 56240)) (56243 60145 (= 56253 . 56427) (%%= 
56429 . 58839) (/= 58841 . 59117) (< 59119 . 59370) (> 59372 . 59627) (<= 59629 . 59881) (>= 59883 . 
60143)) (67278 75424 (%%+ 67288 . 69435) (%%- 69437 . 71360) (%%* 71362 . 73096) (%%/ 73098 . 75422)) 
(75883 78163 (LOGIOR 75893 . 76820) (LOGEQV 76822 . 77189) (LOGNAND 77191 . 77346) (LOGNOR 77348 . 
77501) (LOGANDC1 77503 . 77675) (LOGANDC2 77677 . 77833) (LOGORC1 77835 . 78005) (LOGORC2 78007 . 
78161)) (78210 79054 (BOOLE 78220 . 79052)) (79612 79969 (LOGTEST 79622 . 79799) (LOGBITP 79801 . 
79967)) (79970 80364 (ASH 79980 . 80362)) (80365 82676 (LOGCOUNT 80375 . 81773) (%%LOGCOUNT 81775 . 
82674)) (82677 84602 (INTEGER-LENGTH 82687 . 84600)) (84727 85096 (BYTE-SIZE 84737 . 84911) (
BYTE-POSITION 84913 . 85094)) (85163 85662 (LDB-TEST 85173 . 85358) (MASK-FIELD 85360 . 85660)) (85729
 86038 (DEPOSIT-FIELD 85739 . 86036)))))
STOP