(FILECREATED "17-Sep-86 15:06:57" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;40
 122580 

      changes to:  (FNS REM FLOAT-RADIX)

      previous date: "11-Sep-86 16:42:40" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;39)


(* 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. -- By Kelly Roach *)
        (COMS (* Miscellaneous. *)
              (FNS ISQRT PRIMEP PHASE SIGNUM %%SIGNUM))
        (COMS (* Section 2.1.2 Ratios. *)
              (STRUCTURES RATIO)
              (DECLARE: DONTEVAL@LOAD DOCOPY (P (* The following makes NUMBERP true on ratios *)
                                                (\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE RATIO))
                                                       (LOGOR \TT.NUMBERP \TT.ATOM))))
              (FNS NUMERATOR DENOMINATOR RATIONALP RATIONAL RATIONALIZE %%RATIO-PRINT %%BUILD-RATIO 
                   %%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))))
              (FNS COMPLEX REALPART IMAGPART %%COMPLEX+ %%COMPLEX- %%COMPLEX* %%COMPLEX/ 
                   %%COMPLEX-ABS %%COMPLEX-MINUS %%COMPLEX-TIMESI CONJUGATE %%COMPLEX-PRINT))
        (COMS (* Section 12.2 Predicates on Numbers. *)
              (* MINUSP is made to work on ratios. Otherwise, backwards compatible. *)
              (FNS NEW-MINUSP)
              (DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE NEW-MINUSP)
                                                      (QUOTE MINUSP))))
              (FNS CL:ZEROP)
              (FNS EVENP ODDP PLUSP))
        (COMS (* Section 12.3 Comparisons on Numbers. *)
              (FNS %%= %%>)
              (FNS = %%= /= < > <= >=)
              (PROP DMACRO = /= < > <= >=)
              (* MAX and MIN are OK because they use GREATERP and GREATERP is fixed by this file to 
                 work on ratios. *))
        (COMS (* Section 12.4 Arithmetic Operations. *)
              (FNS + - CL:* / %%/ 1+ 1-)
              (PROP DMACRO + - CL:* / 1+ 1-)
              (DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE +)
                                                      (QUOTE PLUS))
                                                (MOVD (QUOTE -)
                                                      (QUOTE DIFFERENCE))
                                                (MOVD (QUOTE 1+)
                                                      (QUOTE ADD1))
                                                (MOVD (QUOTE 1-)
                                                      (QUOTE SUB1))
                                                (MOVD (QUOTE CL:*)
                                                      (QUOTE TIMES))))
              (* INCF and DECF implemented by CMLSETF. *)
              (* 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. *)
              (FNS FLOAT \FLOAT)
              (* 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 (* * LLARITH replacements. Either you have to live with these replacements or you have 
                 to start fixing CLISP for loops, the history mechanism etc. Larry tried taking these 
                 out and the things I had fixed by putting these replacements in started breaking 
                 again. These replacements are supposed to be good for you in any case. *)
              (COMS (* Non ufns *)
                    (* GREATERP and LESSP are made to work on ratios. EQP, ABS, and MINUS is fixed to 
                       work on ratios and complexs. *)
                    (FNS NEW-LESSP NEW-EQP NEW-ABS NEW-MINUS)
                    (DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE %%>)
                                                            (QUOTE GREATERP))
                                                      (MOVD (QUOTE NEW-LESSP)
                                                            (QUOTE LESSP))
                                                      (MOVD (QUOTE NEW-EQP)
                                                            (QUOTE EQP))
                                                      (MOVD (QUOTE NEW-ABS)
                                                            (QUOTE ABS))
                                                      (MOVD (QUOTE NEW-MINUS)
                                                            (QUOTE MINUS)))))
              (COMS (* New LLARITH UFNS *)
                    (COMS (* INTEGER ARITH UFNS .UNBOX. is made to understand RATIOs so integer arith 
                             ufns must be recompiled. \IQUOTREM has not changed, but \IQUOTREM uses 
                             .UNBOX. and NEW-SLOWIQUOTIENT and NEW-IREMAINDER use \IQUOTREM. *)
                          (DECLARE: EVAL@COMPILE DONTCOPY (MACROS .CMLUNBOX. .CMLIQUOTREM.))
                          (FNS NEW-SLOWIPLUS2 NEW-SLOWIDIFFERENCE NEW-SLOWITIMES2 NEW-SLOWIQUOTIENT 
                               NEW-IREMAINDER NEW-SLOWIGREATERP))
                    (DECLARE: DONTEVAL@LOAD DOCOPY (P (\SETUFNENTRY (CAR (\FINDOP (QUOTE IPLUS2)))
                                                             (QUOTE NEW-SLOWIPLUS2)
                                                             2 0)
                                                      (\SETUFNENTRY (CAR (\FINDOP (QUOTE IDIFFERENCE)
                                                                                ))
                                                             (QUOTE NEW-SLOWIDIFFERENCE)
                                                             2 0)
                                                      (\SETUFNENTRY (CAR (\FINDOP (QUOTE ITIMES2)))
                                                             (QUOTE NEW-SLOWITIMES2)
                                                             2 0)
                                                      (\SETUFNENTRY (CAR (\FINDOP (QUOTE IQUOTIENT)))
                                                             (QUOTE NEW-SLOWIQUOTIENT)
                                                             2 0)
                                                      (\SETUFNENTRY (CAR (\FINDOP (QUOTE IREMAINDER))
                                                                         )
                                                             (QUOTE NEW-IREMAINDER)
                                                             2 0)
                                                      (\SETUFNENTRY (CAR (\FINDOP (QUOTE IGREATERP)))
                                                             (QUOTE NEW-SLOWIGREATERP)
                                                             2 0)))))
        (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)
              (INITVARS (BOOLE-CLR 0)
                     (BOOLE-SET 1)
                     (BOOLE-1 2)
                     (BOOLE-2 3)
                     (BOOLE-C1 4)
                     (BOOLE-C2 5)
                     (BOOLE-AND 6)
                     (BOOLE-IOR 7)
                     (BOOLE-XOR 8)
                     (BOOLE-EQV 9)
                     (BOOLE-NAND 10)
                     (BOOLE-NOR 11)
                     (BOOLE-ANDC1 12)
                     (BOOLE-ANDC2 13)
                     (BOOLE-ORC1 14)
                     (BOOLE-ORC2 15))
              (* 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))
        (DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                               LLFLOAT LLCODE 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 FLOAT LCM %%GCD CL:GCD / CL:* - + 
                            >= <= > < /= = PLUSP ODDP EVENP CL:ZEROP %%COMPLEX-PRINT %%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* %%BUILD-RATIO RATIONALIZE 
                            RATIONAL 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. -- By Kelly Roach *)





(* Miscellaneous. *)


(DEFINEQ

(ISQRT

  (CL:LAMBDA (INTEGER)
                                       (* kbr: "12-Jul-86 18:05")

          
          (* 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 INTEGER)
                     (NOT (MINUSP INTEGER)))
                (CL:DO* ((LG (INTEGER-LENGTH
 INTEGER))
                         (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)
                                    INTEGER)
                                   (SETQ LO MID)
                                   (SETQ HI MID))))
                (CL:ERROR "Isqrt: ~S argument must be a nonnegative integer" INTEGER))))

(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)
                                        (* kbr: "23-Jul-86 16:19")

         (COND
            ((COMPLEXP NUMBER)
             (CL:ATAN (COMPLEX-IMAGPART NUMBER)
                    (COMPLEX-REALPART NUMBER)))
            ((MINUSP NUMBER)
             %%PI)
            (T 
          
          (* Page 206 of the silver book: The phase of a positive non-complex number is 

          zero. The phase of zero is arbitrarily defined to be zero.

          The result is a floating-point number. *)


               0.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))
                  (:PRINT-FUNCTION %%RATIO-PRINT)) (NUMERATOR :READ-ONLY) (DENOMINATOR :READ-ONLY))

(DECLARE: DONTEVAL@LOAD DOCOPY 
(* The following makes NUMBERP true on ratios *)
(\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE RATIO))
       (LOGOR \TT.NUMBERP \TT.ATOM))
)
(DEFINEQ

(NUMERATOR

  (CL:LAMBDA (RATIONAL
)
                                      (* kbr: "12-Jul-86 18:05")

                                                             (* Returns the numerator of a 

                                                             rational.)

         (ETYPECASE RATIONAL (INTEGER RATIONAL)
                (RATIO (RATIO-NUMERATOR RATIONAL)))))

(DENOMINATOR

  (CL:LAMBDA (RATIONAL
)
                                      (* kbr: "12-Jul-86 18:05")

                                                             (* Returns the denominator of a 

                                                             rational. *)

         (ETYPECASE RATIONAL (INTEGER 1)
                (RATIO (RATIO-DENOMINATOR RATIONAL)))))

(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 (NUMBER)
                                        (* kbr: "14-Aug-86 15:07")

                                                             (* Rationalize does a rational, but it 

                                                             assumes that floats are only accurate 

                                                             to their precision, and generates a 

                                                             good rational aproximation of them.

                                                             *)

         (ETYPECASE NUMBER ((OR INTEGER RATIO)
                            NUMBER)
                (FLOAT
 (%%RATIONALIZE-FLOAT
 NUMBER))
                (COMPLEX
 (%%MAKE-COMPLEX (RATIONALIZE
 (REALPART
 NUMBER))
                                (RATIONALIZE
 (IMAGPART
 NUMBER)))))))

(%%RATIO-PRINT

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

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

                                                             tables)

             (PRIN1 "|." STREAM)
             (\PRINDATUM (LIST (QUOTE /)
                               TOP BOTTOM)
                    STREAM))
            (T (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))

(%%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)))))))

(%%RATIONALIZE-FLOAT

  (LAMBDA (X)
                                                (* kbr: "20-Aug-86 19:36")

                                                             (* Produce a rational approximating X.

                                                             *)

    (PROG (SIGN XNUM XDEN EXPT R F OLDNUM OLDDEN NUM DEN)
          
          (* * This routine presupposes familiarity with topics in number theory and IEEE 

          FLOATP representation. The algorithm uses a standard mathematical technique for 

          approximating a real valued number, but in very sophisticated form more 

          amenable to the computer and the nature of IEEE FLOATPs and is not an algorithm 

          you are likely to find published anywhere.

          Warning to the wise: If you don't know anything about the theory of continued 

          fractions, then I suggest you look but don't touch.

          *)

          
          (* * First of all, X is range reduced to the interval

          ((SQRT .5) (SQRT 2)) excluding (SQRT 2) This strategy has the property that 

          FLOATPs differing only by sign and a power of two rationalize into rationals 

          differing only by sign and a power of two.

          The choice of interval ((SQRT .5) (SQRT 2)) versus another interval such as

          (.5 1) is due to our wanting there to be roughly the same number of significant 

          bits in the numerator as in the denominator of the answer that is returned.

          Here, significant bits is taken to mean the number of bits in the results 

          returned by the continued fraction approximation and excludes the bits 

          resulting from multiplying by the power of two.

          *)


          (PROGN                                             (* Get SIGN XNUM XDEN and EXPT for X.

                                                             *)

                 (MULTIPLE-VALUE-SETQ (XNUM EXPT SIGN)
                        (INTEGER-DECODE-FLOAT
 X))
                 (COND
                    ((EQ XNUM 0)                             (* In case X = 0, just return 0 *)

                     (RETURN 0)))                            (* 24 because FLOATPs have 24 bit 

                                                             mantissas. *)

                 (SETQ XDEN (CONSTANT (EXPT 2 24)))
                 (SETQ EXPT (+
 EXPT 24))
                 (SETQ R (DECODE-FLOAT
 X))
                 (COND
                    ((<
 XNUM 11863283)                       (* 11863283 = (SQRT .5) mantissa.

                                                             *)

                     (SETQ XDEN (LRSH XDEN 1))
                     (SETQ EXPT (1-
 EXPT))
                     (SETQ R (CL:*
 2 R))))
          
          (* At this point, X = (CL:* (/ XNUM XDEN)

          (EXPT 2 EXPT)) and (/ XNUM XDEN) is in the interval

          ((SQRT .5) (SQRT 2)) *)


                 )
          (SETQ OLDNUM 1)
          (SETQ OLDDEN 0)
          (SETQ NUM 0)
          (SETQ DEN 1)
      CFLOOP
                                                             (* Continued fraction approximation 

                                                             loop. *)

          (COND
             ((AND (NOT (EQ DEN 0))
                   (=
 (FQUOTIENT NUM DEN)
                      R))
              (COND
                 ((>
 EXPT 0)
                  (SETQ NUM (ASH
 NUM EXPT)))
                 ((<
 EXPT 0)
                  (SETQ DEN (ASH
 DEN (-
 EXPT)))))
              (RETURN (/
 (CL:*
 SIGN NUM)
                         DEN))))
          (swap
 XNUM XDEN)
          (MULTIPLE-VALUE-SETQ (F XNUM)
                 (TRUNCATE
 XNUM XDEN))
          (SETQ NUM (+
 OLDNUM (CL:*
 F (SETQ OLDNUM NUM))))
          (SETQ DEN (+
 OLDDEN (CL:*
 F (SETQ OLDDEN DEN))))
          (GO CFLOOP))))

(%%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 %%COMPLEX-PRINT)) (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))
)
(DEFINEQ

(COMPLEX

  (CL:LAMBDA (REALPART
 &OPTIONAL (IMAGPART
 0))
               (* kbr: " 9-Jul-86 21:05")

          
          (* Builds a complex number from the specified components.

          Note: IMAGPART = 0.0 or floating REALPART implies that we must build a complex 

          not a real according to the manual while IMAGPART = 0 and rational REALPART 

          implies that we build a real. Strange, but that's the way Guy Steele wants it.

          *)


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

(%%COMPLEX-PRINT

  (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 made to work on ratios. Otherwise, backwards compatible. *)


(DEFINEQ

(NEW-MINUSP

  (LAMBDA (NUMBER)
                                           (* kbr: " 9-Jul-86 22:10")

    (%%>
 0 NUMBER)))
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(MOVD (QUOTE NEW-MINUSP)
      (QUOTE MINUSP))
)
(DEFINEQ

(CL:ZEROP

  (CL:LAMBDA (NUMBER)
                                        (* kbr: "21-Jul-86 17:19")

         (=
 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.3 Comparisons on Numbers. *)


(DEFINEQ

(%%=

  (LAMBDA (X Y)
                                              (* kbr: " 9-Jul-86 19: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 (%%=
 X (COMPLEX-REALPART Y))
                                                   (%%=
 0 (COMPLEX-IMAGPART 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 (%%=
 X (COMPLEX-REALPART Y))
                                           (%%=
 (COMPLEX-IMAGPART Y)
                                                0)))))
               (FLOAT
 (CTYPECASE Y (FLOAT
                    (* EQL failed)

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

(%%>

  (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)
                     (* kbr: " 9-Jul-86 19:28")

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

(%%=

  (LAMBDA (X Y)
                                              (* kbr: " 9-Jul-86 19: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 (%%=
 X (COMPLEX-REALPART Y))
                                                   (%%=
 0 (COMPLEX-IMAGPART 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 (%%=
 X (COMPLEX-REALPART Y))
                                           (%%=
 (COMPLEX-IMAGPART Y)
                                                0)))))
               (FLOAT
 (CTYPECASE Y (FLOAT
                    (* EQL failed)

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

(/=

  (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 (NUMBER &REST MORE-NUMBERS)
                     (* kbr: " 9-Jul-86 19:18")

         (OR (NULL MORE-NUMBERS)
             (AND (%%>
 (CAR MORE-NUMBERS)
                       NUMBER)
                  (for
 TAIL on
 MORE-NUMBERS while
 (CDR TAIL) always
 (%%>
 (CADR TAIL)
                                                                         (CAR TAIL)))))))

(>

  (CL:LAMBDA (NUMBER &REST MORE-NUMBERS)
                     (* kbr: " 9-Jul-86 19:16")

         (OR (NULL MORE-NUMBERS)
             (AND (%%>
 NUMBER (CAR MORE-NUMBERS))
                  (for
 TAIL on
 MORE-NUMBERS while
 (CDR TAIL) always
 (%%>
 (CAR TAIL)
                                                                         (CADR TAIL)))))))

(<=

  (CL:LAMBDA (NUMBER &REST MORE-NUMBERS)
                     (* kbr: " 9-Jul-86 19:27")

         (OR (NULL MORE-NUMBERS)
             (AND (NOT (%%>
 NUMBER (CAR MORE-NUMBERS)))
                  (for
 TAIL on
 MORE-NUMBERS while
 (CDR TAIL) always
 (NOT (%%>
 (CAR TAIL)
                                                                              (CADR TAIL))))))))

(>=

  (CL:LAMBDA (NUMBER &REST MORE-NUMBERS)
                     (* kbr: " 9-Jul-86 20:46")

         (OR (NULL MORE-NUMBERS)
             (AND (NOT (%%>
 (CAR MORE-NUMBERS)
                            NUMBER))
                  (for
 TAIL on
 MORE-NUMBERS while
 (CDR TAIL) always
 (NOT (%%>
 (CADR TAIL)
                                                                              (CAR TAIL))))))))
)

(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 because they use GREATERP and GREATERP is fixed by this file to work on 
ratios. *)





(* 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)
                                            (* kbr: "11-Sep-86 16:41")

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

                                                             handles the case of two args both 

                                                             FIXPs)

    (CTYPECASE N1 (INTEGER (CTYPECASE N2 (INTEGER (COND
                                                     ((OR (EQ N1 MIN.INTEGER)
                                                          (EQ N1 MAX.INTEGER)
                                                          (EQ N2 MIN.INTEGER)
                                                          (EQ N2 MAX.INTEGER)
                                                          (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 (NUMBER)
                                           (* kbr: "12-Jul-86 18:05")

    (+
 NUMBER 1)))

(1-

  (LAMBDA (NUMBER)
                                           (* kbr: "12-Jul-86 18:05")

    (-
 NUMBER 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)) )
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(MOVD (QUOTE +)
      (QUOTE PLUS))
(MOVD (QUOTE -)
      (QUOTE DIFFERENCE))
(MOVD (QUOTE 1+)
      (QUOTE ADD1))
(MOVD (QUOTE 1-)
      (QUOTE SUB1))
(MOVD (QUOTE CL:*)
      (QUOTE TIMES))
)



(* INCF and DECF implemented by CMLSETF. *)





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


(DEFINEQ

(CL:GCD

  (CL:LAMBDA (&REST INTEGERS)
                                (* kbr: " 9-Jul-86 17:36")

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

         (PROG (ANSWER)
               (COND
                  ((NULL INTEGERS)
                   (RETURN 0)))
               (OR (INTEGERP (CAR INTEGERS))
                   (CL:ERROR "GCD: ~S is not an integer." (CAR INTEGERS)))
               (SETQ ANSWER (ABS (CAR INTEGERS)))
               (for
 INTEGER in
 (CDR INTEGERS) do
 (OR (INTEGERP INTEGER)
                                                     (CL:ERROR "GCD: ~S is not an integer." INTEGER))
                                                 (SETQ ANSWER (%%GCD
 ANSWER INTEGER))
                                                 (COND
                                                    ((EQ ANSWER 1)
                                                     (RETURN))))
               (RETURN ANSWER))))

(%%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 (INTEGER &REST MORE-INTEGERS)
                   (* kbr: " 9-Jul-86 17:45")

          
          (* 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.

          *)

                                                             (* Returns the least common multiple 

                                                             of one or more integers.

                                                             *)

         (PROG (ANSWER)
               (OR (INTEGERP INTEGER)
                   (CL:ERROR "LCM: ~S is not an integer." INTEGER))
               (SETQ ANSWER (ABS INTEGER))
               (for
 INTEGER in
 MORE-INTEGERS do
 (OR (INTEGERP INTEGER)
                                                    (CL:ERROR "LCM: ~S is not an integer." INTEGER))
                                                (SETQ ANSWER (CL:*
 (/
 (ABS INTEGER)
                                                                      (%%GCD
 ANSWER INTEGER))
                                                                   ANSWER))
                                                (COND
                                                   ((EQ ANSWER 0)
                                                    (RETURN))))
               (RETURN ANSWER))))
)



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


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


(DEFINEQ

(FLOAT

  (CL:LAMBDA (NUMBER &OPTIONAL OTHER)
                        (* kbr: " 8-May-86 16:24")

                                                             (* compiles this way, too)

         (\DTEST NUMBER (QUOTE FLOATP))))

(\FLOAT

  (LAMBDA (X)
                                                (* kbr: " 9-Jul-86 21:24")

    (OR (FLOATP X)
        (COND
           ((FIXP X)
            (SELECTC (NTYPX X)
                (\FIXP (LET ((HI (fetch
 (FIXP HINUM) of
 X))
                             (LO (fetch
 (FIXP LONUM) of
 X))
                             (SIGN 0))
                            (COND
                               ((IGREATERP HI MAX.POS.HINUM)
                                (.NEGATE. HI LO)
                                (SETQ SIGN 1)))
                            (\MAKEFLOAT SIGN (IPLUS \EXPONENT.BIAS 31)
                                   HI LO T)))
                (\SMALLP (LET* ((HI 0)
                                (SIGN 0)
                                (LO (COND
                                       ((IGEQ X 0)
                                        X)
                                       (T (SETQ SIGN 1)      (* X is negative--negate it)

                                          (COND
                                             ((EQ 0 (\LOLOC X))
                                                             (* Min small integer)

                                              (SETQ HI 1)
                                              0)
                                             (T (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (\LOLOC X)))))))
                                    ))
                               (\MAKEFLOAT SIGN (IPLUS \EXPONENT.BIAS 31)
                                      HI LO T)))
                (\BIGNUM.TO.FLOAT X)))
           ((RATIO-P X)
            (FQUOTIENT (RATIO-NUMERATOR X)
                   (RATIO-DENOMINATOR X)))
           (T (\FLOAT
 (LISPERROR "NON-NUMERIC ARG" X T)))))))
)



(* 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))
                  (* kbr: "22-Jul-86 15:17")

                                                             (* 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
 (\FIXP.FROM.FLOATP (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))
             (* kbr: "12-Jul-86 19:43")

                                                             (* Rounds number (or number/divisor) 

                                                             to nearest integer. The second 

                                                             returned value is the remainder.

                                                             *)

         (LET ((THRESH (CL:IF DIVP (/
 (ABS DIVISOR)
                                      2)
                              .5)))
              (MULTIPLE-VALUE-BIND (TRU REM)
                     (TRUNCATE
 NUMBER DIVISOR)
                     (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)
                                (* kbr: "17-Sep-86 15:03")

                                                             (* Returns second result of TRUNCATE.

                                                             *)

         (MULTIPLE-VALUE-BIND (TRU REM)
                (TRUNCATE
 NUMBER DIVISOR)
                (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 (FLOAT
)
                                         (* kbr: "20-Aug-86 17:35")

         (SETQ FLOAT (\DTEST FLOAT (QUOTE FLOATP)))
         (COND
            ((=
 FLOAT 0.0)
             (VALUES 0.0 0 1.0))
            (T (VALUES (create
 FLOATP
                              SIGNBIT _ 0
                              EXPONENT _ (SUB1 \EXPONENT.BIAS)
                              HIFRACTION _ (fetch
 (FLOATP HIFRACTION) of
 FLOAT)
                              LOFRACTION _ (fetch
 (FLOATP LOFRACTION) of
 FLOAT))
                      (IDIFFERENCE (fetch
 (FLOATP EXPONENT) of
 FLOAT)
                             (SUB1 \EXPONENT.BIAS))
                      (COND
                         ((EQ (fetch
 (FLOATP SIGNBIT) of
 FLOAT)
                              0)
                          1.0)
                         (T -1.0)))))))

(SCALE-FLOAT

  (LAMBDA (FLOAT
 INTEGER)
                                    (* kbr: "20-Aug-86 17:40")

                                                             (* \MAKEFLOAT knows how to handle 

                                                             underflow and overflow possibilities.

                                                             *)

    (SETQ FLOAT (\DTEST FLOAT (QUOTE FLOATP)))
    (COND
       ((=
 FLOAT 0.0)
        0.0)
       (T (\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 (FLOAT
)
                                         (* kbr: "17-Sep-86 15:04")

         (DECLARE
 (IGNORE FLOAT))
         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 (FLOAT
)
                                         (* kbr: "16-Aug-86 19:35")

         (TYPECASE FLOAT (FLOAT
 24)
                (T (CL:ERROR "Float-digits: ~A not a float" FLOAT)))))

(FLOAT-PRECISION

  (CL:LAMBDA (FLOAT
)
                                         (* kbr: "12-Jul-86 18:29")

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

(INTEGER-DECODE-FLOAT

  (CL:LAMBDA (FLOAT
)
                                         (* kbr: "20-Aug-86 17:39")

         (SETQ FLOAT (\DTEST FLOAT (QUOTE FLOATP)))
         (COND
            ((=
 FLOAT 0.0)
             (VALUES 0 0 1))
            (T (VALUES (IPLUS (LLSH (IPLUS 128 (fetch
 (FLOATP HIFRACTION) of
 FLOAT))
                                    16)
                              (fetch
 (FLOATP LOFRACTION) of
 FLOAT))
                      (IDIFFERENCE (fetch
 (FLOATP EXPONENT) of
 FLOAT)
                             (IPLUS \EXPONENT.BIAS 23))
                      (COND
                         ((EQ (fetch
 (FLOATP SIGNBIT) of
 FLOAT)
                              0)
                          1)
                         (T -1)))))))
)



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


(* * LLARITH replacements. Either you have to live with these replacements or you have to start
 fixing CLISP for loops, the history mechanism etc. Larry tried taking these out and the things
 I had fixed by putting these replacements in started breaking again. These replacements are 
supposed to be good for you in any case. *)





(* Non ufns *)





(* GREATERP and LESSP are made to work on ratios. EQP, ABS, and MINUS is fixed to work on 
ratios and complexs. *)


(DEFINEQ

(NEW-LESSP

  (LAMBDA (X Y)
                                              (* kbr: " 9-Jul-86 22:00")

    (%%>
 Y X)))

(NEW-EQP

  (LAMBDA (X Y)
                                              (* Pavel "15-Aug-86 19:47")

    (COND
       ((EQ X Y))
       ((AND (NUMBERP X)
             (NUMBERP Y))
        (%%=
 X Y))
       (T (\EXTENDED.EQP X Y)))))

(NEW-ABS

  (LAMBDA (X)
                                                (* kbr: " 9-Jul-86 22:17")

    (CTYPECASE X (INTEGER (COND
                             ((ILESSP X 0)
                              (IDIFFERENCE 0 X))
                             (T X)))
           (SINGLE-FLOAT (COND
                            ((FLESSP X 0.0)
                             (FDIFFERENCE 0.0 X))
                            (T X)))
           (RATIO (COND
                     ((ILESSP (NUMERATOR
 X)
                             0)
                      (%%MAKE-RATIO (IDIFFERENCE 0 (NUMERATOR
 X))
                             (DENOMINATOR
 X)))
                     (T X)))
           (COMPLEX
 (%%COMPLEX-ABS
 X)))))

(NEW-MINUS

  (LAMBDA (N)
                                                (* kbr: " 8-May-86 18:31")

    (%%-
 0 N)))
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(MOVD (QUOTE %%>)
      (QUOTE GREATERP))
(MOVD (QUOTE NEW-LESSP)
      (QUOTE LESSP))
(MOVD (QUOTE NEW-EQP)
      (QUOTE EQP))
(MOVD (QUOTE NEW-ABS)
      (QUOTE ABS))
(MOVD (QUOTE NEW-MINUS)
      (QUOTE MINUS))
)



(* New LLARITH UFNS *)





(* INTEGER ARITH UFNS .UNBOX. is made to understand RATIOs so integer arith ufns must be 
recompiled. \IQUOTREM has not changed, but \IQUOTREM uses .UNBOX. and NEW-SLOWIQUOTIENT and 
NEW-IREMAINDER use \IQUOTREM. *)


(DECLARE: EVAL@COMPILE DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS .CMLUNBOX. MACRO ((V HV LV FORM)
                            (PROG NIL UBLP
                                  (SELECTC (NTYPX V)
                                         (\FIXP (SETQ HV (ffetch (FIXP HINUM)
                                                                of V))
                                                (SETQ LV (ffetch (FIXP LONUM)
                                                                of V)))
                                         (\SMALLP (COND ((ILEQ 0 V)
                                                         (SETQ HV 0)
                                                         (SETQ LV V))
                                                        (T (SETQ HV 65535)
                                                           (SETQ LV (\LOLOC V)))))
                                         (\FLOATP (SETQ V (\FIXP.FROM.FLOATP V))
                                                (GO UBLP))
                                         (COND ((RATIO-P V)
                                                (SETQ V (IQUOTIENT (RATIO-NUMERATOR V)
                                                               (RATIO-DENOMINATOR V)))
                                                (GO UBLP))
                                               (T (TYPECASE V (NUMBER (COND ((QUOTE FORM)
                                                                             (* If there is a FORM, 
                                                                                then compiler will 
                                                                                compile this branch 
                                                                                of macro. *)
                                                                             FORM)
                                                                            (T (* If there is no 
                                                                                  FORM, then compiler 
                                                                                  will compile this 
                                                                                  branch of macro. *)
                                                                               (SETQ V
                                                                                     (\LISPERROR
                                                                                      V 
                                                                                      "ARG NOT FIXP" 
                                                                                      T))
                                                                               (GO UBLP))))
                                                         (T (SETQ V (LISPERROR "NON-NUMERIC ARG" V T)
                                                                  )
                                                            (GO UBLP)))))))))
(PUTPROPS .CMLIQUOTREM. MACRO ((X Y QUO REM)
                               (PROG (HX LX HY LY SIGNQUOTIENT SIGNREMAINDER (CNT 0)
                                         (HZ 0)
                                         (LZ 0))
                                     (.CMLUNBOX. X HX LX (GO RETBIG))
                                     (.CMLUNBOX. Y HY LY (GO RETBIG))
                                     (COND ((IGREATERP HX MAX.POS.HINUM)
                                            (.NEGATE. HX LX)
                                            (SETQ SIGNQUOTIENT (SETQ SIGNREMAINDER T))))
                                     (* Remainder has sign of dividend)
                                     (COND ((IGREATERP HY MAX.POS.HINUM)
                                            (.NEGATE. HY LY)
                                            (SETQ SIGNQUOTIENT (NOT SIGNQUOTIENT))))
                                     (COND ((NEQ HX 0)
                                            (GO BIGDIVIDEND))
                                           ((NEQ HY 0)
                                            (* Y is big, X is small, so result is 0)
                                            (GO DONE))
                                           ((EQ 0 LX)
                                            (GO RET0))
                                           ((EQ 0 LY)
                                            (GO DIVZERO))
                                           ((EQ LY 1)
                                            (SETQ LZ LX)
                                            (SETQ LX 0)
                                            (GO DONE)))
                                     (* here we are dividing small X by small Y, and we know Y gt 1)
                                     LP1
                                     (* shift Y left until it is as big as X, and count how many 
                                        times)
                                     (COND ((AND (ILESSP LY LX)
                                                 (ILEQ LY MAX.POS.HINUM))
                                            (SETQ LY (LLSH LY 1))
                                            (SETQ CNT (ADD1 CNT))
                                            (GO LP1)))
                                     LP2
                                     (* now start dividing Y into X by subtracting and shifting, 
                                        ending up with Y shifted back where it started)
                                     (COND ((ILEQ LY LX)
                                            (SETQ LX (IDIFFERENCE LX LY))
                                            (* Y divides X once, so add bit into quotient)
                                            (SETQ LZ (ADD1 LZ))))
                                     (SETQ LY (LRSH LY 1))
                                     (SETQ CNT (SUB1 CNT))
                                     (COND ((IGEQ CNT 0)
                                            (SETQ LZ (LLSH LZ 1))
                                            (GO LP2)))
                                     (GO DONE)
                                     BIGDIVIDEND
                                     (* X is big, so result may be big. Algorithm is same as above, 
                                        but everything is doubled in length)
                                     (COND ((EQ 0 HY)
                                            (COND ((EQ 0 (SETQ HY LY))
                                                   (GO DIVZERO))
                                                  ((AND SIGNREMAINDER (NULL SIGNQUOTIENT)
                                                        (EQ 1 LY)
                                                        (EQ HX \SIGNBIT)
                                                        (EQ 0 LX))
                                                   (* Means that X is MIN.FIXP and Y is -1)
                                                   (GO RETBIG)))
                                            (SETQ LY 0)
                                            (SETQ CNT 16))
                                           ((AND SIGNREMAINDER (NULL SIGNQUOTIENT)
                                                 (EQ 0 LX)
                                                 (EQ HX \SIGNBIT)
                                                 (EQ 0 HY)
                                                 (EQ 1 LY))
                                            (* Means that X is MIN.FIXP and Y is -1)
                                            (GO RETBIG)))
                                     BIGLP
                                     (COND ((AND (OR (AND (EQ HY HX)
                                                          (ILESSP LY LX))
                                                     (ILESSP HY HX))
                                                 (ILESSP HY MAX.POS.HINUM))
                                            (.LLSH1. HY LY)
                                            (SETQ CNT (ADD1 CNT))
                                            (GO BIGLP)))
                                     BIGLP2
                                     (COND ((OR (ILESSP HY HX)
                                                (AND (EQ HY HX)
                                                     (ILEQ LY LX)))
                                            (* Y divides X, so subtract Y from X and put a bit in 
                                               quotient)
                                            (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY)
                                                            (.SUBSMALL. LX LY)))
                                            (SETQ LZ (ADD1 LZ))
                                            (* note that this never overflows, because of the 
                                               preceding left shift)))
                                     (.LRSH1. HY LY)
                                     (SETQ CNT (SUB1 CNT))
                                     (COND ((IGEQ CNT 0)
                                            (.LLSH1. HZ LZ)
                                            (GO BIGLP2)))
                                     DONE
                                     (COND ((QUOTE REM)
                                            (* remainder is left in X)
                                            (COND (SIGNREMAINDER (.NEGATE. HX LX)))
                                            (SETQ REM (\MAKENUMBER HX LX))))
                                     (COND ((QUOTE QUO)
                                            (COND (SIGNQUOTIENT (.NEGATE. HZ LZ)))
                                            (SETQ QUO (\MAKENUMBER HZ LZ))))
                                     (RETURN)
                                     DIVZERO
                                     (SELECTQ \OVERFLOW (T (ERROR "DIVIDE BY ZERO" Y))
                                            (GO RET0))
                                     RET0
                                     (COND ((QUOTE REM)
                                            (SETQ REM 0)))
                                     (COND ((QUOTE QUO)
                                            (SETQ QUO 0)))
                                     (RETURN)
                                     RETBIG
                                     (if (QUOTE QUO)
                                         then
                                         (SETQ QUO (\BIGNUM.QUOTIENT X Y)))
                                     (if (QUOTE REM)
                                         then
                                         (SETQ REM (\BIGNUM.REMAINDER X Y)))
                                     (RETURN))))
)
)
(DEFINEQ

(NEW-SLOWIPLUS2

  (LAMBDA (X Y)
                                              (* lmm "12-Apr-85 08:51")

    (\CALLME (QUOTE IPLUS))
    (PROG (HX LX HY LY SIGNX)
          (.CMLUNBOX. X HX LX (GO RETBIG))
          (.CMLUNBOX. Y HY LY (GO RETBIG))
          (SETQ SIGNX (IGREATERP HX MAX.POS.HINUM))
          (SETQ HX (COND
                      ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
                       (IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))))
                      (T (IPLUS HX HY))))                    (* Add high parts)

          (SETQ LX (COND
                      ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
                                                             (* Carry into high part.)

                       (SETQ HX (COND
                                   ((EQ HX MAX.SMALL.INTEGER)
                                    0)
                                   (T (ADD1 HX))))
                       (IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY))))
                      (T (IPLUS LX LY))))
          (COND
             ((AND (EQ SIGNX (IGREATERP HY MAX.POS.HINUM))
                   (NOT (EQ SIGNX (IGREATERP HX MAX.POS.HINUM))))
                                                             (* overflow occurs if X and Y are same 

                                                             sign, but result is opposite sign)

              (GO RETBIG)))
          (RETURN (\MAKENUMBER HX LX))
      RETBIG
          (RETURN (\BIGNUM.PLUS X Y)))))

(NEW-SLOWIDIFFERENCE

  (LAMBDA (X Y)
                                              (* lmm "12-Apr-85 07:37")

    (\CALLME (QUOTE IDIFFERENCE))
    (PROG (HX LX HY LY SIGNX)
          (.CMLUNBOX. X HX LX (GO RETBIG))
          (.CMLUNBOX. Y HY LY (GO RETBIG))                   (* Allow this unboxing before the 

                                                             following test so that error checking 

                                                             will be performed on Y)

          (COND
             ((EQ Y 0)
              (RETURN (\MAKENUMBER HX LX))))
          (.NEGATE. HY LY)
          (SETQ SIGNX (IGREATERP HX MAX.POS.HINUM))
          (COND
             ((COND
                 ((AND (ZEROP LY)
                       (EQ HY \SIGNBIT))                     (* Y = -Y = Min.integer.

                                                             Overflow occurs if X is positive)

                  (SETQ HX (LOGXOR HX HY))
                  (NOT SIGNX))
                 (T (SETQ HX (COND
                                ((IGREATERP HX (IDIFFERENCE MAX.SMALL.INTEGER HY))
                                 (IDIFFERENCE HX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER HY))))
                                (T (IPLUS HX HY))))          (* Add high parts)

                    (SETQ LX (COND
                                ((IGREATERP LX (IDIFFERENCE MAX.SMALL.INTEGER LY))
                                                             (* Carry into high part.)

                                 (SETQ HX (COND
                                             ((EQ HX MAX.SMALL.INTEGER)
                                              0)
                                             (T (ADD1 HX))))
                                 (IDIFFERENCE LX (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER LY))))
                                (T (IPLUS LX LY))))          (* overflow occurs if X and Y are same 

                                                             sign, but result is opposite sign)

                    (AND (EQ SIGNX (IGREATERP HY MAX.POS.HINUM))
                         (NOT (EQ SIGNX (IGREATERP HX MAX.POS.HINUM))))))
              (GO RETBIG)))
          (RETURN (\MAKENUMBER HX LX))
      RETBIG
          (RETURN (\BIGNUM.DIFFERENCE X Y)))))

(NEW-SLOWITIMES2

  (LAMBDA (X Y)
                                              (* lmm "12-Apr-85 08:52")

    (\CALLME (QUOTE ITIMES))
    (COND
       ((OR (EQ X 0)
            (EQ Y 0))
        0)
       (T (PROG (HX HY LX LY SIGN HR LR CARRY)
                (SETQ HR 0)
                (SETQ LR 0)
                (.CMLUNBOX. X HX LX (GO RETBIG))
                (.CMLUNBOX. Y HY LY (GO RETBIG))
                (COND
                   ((IGREATERP HX MAX.POS.HINUM)
                    (COND
                       ((EQUAL X MIN.FIXP)
                        (GO RETBIG)))
                    (.NEGATE. HX LX)
                    (SETQ SIGN T)))
                (COND
                   ((IGREATERP HY MAX.POS.HINUM)
                    (COND
                       ((EQUAL Y MIN.FIXP)
                        (GO RETBIG)))
                    (.NEGATE. HY LY)
                    (SETQ SIGN (NOT SIGN))))
                (COND
                   ((NOT (EQ HY 0))
                    (COND
                       ((NOT (EQ HX 0))
                        (GO OVER)))
                    (swap
 LX LY)
                    (swap
 HX HY)))
            MLP (COND
                   ((ODDP
 (PROG1 LY (SETQ LY (LRSH LY 1))))
                    (COND
                       ((IGREATERP LR (IDIFFERENCE MAX.SMALL.INTEGER LX))
                                                             (* low parts overflow)

                                                             (* make the low word be the less 

                                                             significant bits and return the carry.)

                        (SETQ LR (IDIFFERENCE LR (IDIFFERENCE MAX.SMALL.INTEGER (SUB1 LX))))
                        (SETQ CARRY 1))
                       (T                                    (* no carry just add the low halves.)

                          (SETQ LR (IPLUS LR LX))
                          (SETQ CARRY 0)))
          
          (* the low order part of the answer has been set and CARRY is the numeric value 

          of the carry from the low part either 0 or 1)


                    (COND
                       ((IGREATERP (SETQ HR (IPLUS HR HX CARRY))
                               MAX.POS.HINUM)
                        (COND
                           ((AND (EQ LY 0)
                                 SIGN
                                 (EQ HR (ADD1 MAX.POS.HINUM))
                                 (EQ LR 0))
                            (RETURN MIN.FIXP)))
                        (GO OVER)))))
                (COND
                   ((ZEROP LY)
                    (GO RET)))
                (COND
                   ((IGEQ HX (LRSH (ADD1 MAX.POS.HINUM)
                                   1))
                    (GO OVERTEST)))
                (.LLSH1. HX LX)
                (GO MLP)
            OVERTEST
                (COND
                   ((AND (EQ HX (LRSH (ADD1 MAX.POS.HINUM)
                                      1))
                         (ZEROP LX)
                         SIGN
                         (EQ LY 1)
                         (EQ HR 0)
                         (EQ LR 0))                          (* odd special case)

                    (RETURN MIN.FIXP)))
            OVER
                (GO RETBIG)
            RET (COND
                   (SIGN (.NEGATE. HR LR)))
                (RETURN (\MAKENUMBER HR LR))
            RETBIG
                (RETURN (\BIGNUM.TIMES X Y)))))))

(NEW-SLOWIQUOTIENT

  (LAMBDA (X Y)
                                              (* kbr: " 5-Aug-86 15:45")

    (\CALLME (QUOTE IQUOTIENT))
    (.CMLIQUOTREM. X Y X)
    X))

(NEW-IREMAINDER

  (LAMBDA (X Y)
                                              (* kbr: " 5-Aug-86 15:46")

    (.CMLIQUOTREM. X Y NIL Y)
    Y))

(NEW-SLOWIGREATERP

  (LAMBDA (X Y)
                                              (* lmm "12-Apr-85 07:35")

    (\CALLME (QUOTE IGREATERP
))
    (PROG (HX LX HY LY)
          (.CMLUNBOX. X HX LX (GO RETBIG))
          (.CMLUNBOX. Y HY LY (GO RETBIG))
          (RETURN (COND
                     ((EQ HX HY)
                      (IGREATERP LX LY))
                     (T (IGREATERP (LOGXOR HX \SIGNBIT)
                               (LOGXOR HY \SIGNBIT)))))
      RETBIG
          (RETURN (EQ 1 (\BIGNUM.COMPARE X Y))))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(\SETUFNENTRY (CAR (\FINDOP (QUOTE IPLUS2)))
       (QUOTE NEW-SLOWIPLUS2)
       2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE IDIFFERENCE)))
       (QUOTE NEW-SLOWIDIFFERENCE)
       2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE ITIMES2)))
       (QUOTE NEW-SLOWITIMES2)
       2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE IQUOTIENT)))
       (QUOTE NEW-SLOWIQUOTIENT)
       2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE IREMAINDER)))
       (QUOTE NEW-IREMAINDER)
       2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE IGREATERP)))
       (QUOTE NEW-SLOWIGREATERP)
       2 0)
)



(* 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)
                                            (* kbr: "12-Jul-86 18:32")

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

                                                             handles the case of two args both 

                                                             FIXPs)

    (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)))
                           (FLOAT
 (%%COMPLEX+
 N1 (%%MAKE-COMPLEX N2 0.0)))
                           (RATIO (%%COMPLEX+
 N1 (%%MAKE-COMPLEX N2 0)))
                           (COMPLEX
 (%%COMPLEX+
 N1 N2)))))))

(%%-

  (LAMBDA (N1 N2)
                                            (* kbr: "12-Jul-86 18:32")

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

                                                             Microcode generally handles the case 

                                                             of two args both FIXPs)

    (CTYPECASE N1 (INTEGER (CTYPECASE N2 (INTEGER (IDIFFERENCE N1 N2))
                                  (FLOAT
 (FDIFFERENCE N1 N2))
                                  (RATIO (%%RATIO-
 (%%MAKE-RATIO N1 1)
                                                N2))
                                  (COMPLEX
 (%%COMPLEX-
 (%%MAKE-COMPLEX N1 0)
                                                  N2))))
           (FLOAT
 (CTYPECASE N2 ((OR INTEGER 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)
                                            (* kbr: "11-Sep-86 16:41")

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

                                                             handles the case of two args both 

                                                             FIXPs)

    (CTYPECASE N1 (INTEGER (CTYPECASE N2 (INTEGER (COND
                                                     ((OR (EQ N1 MIN.INTEGER)
                                                          (EQ N1 MAX.INTEGER)
                                                          (EQ N2 MIN.INTEGER)
                                                          (EQ N2 MAX.INTEGER)
                                                          (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))))
)

(RPAQ? BOOLE-CLR
 0)

(RPAQ? BOOLE-SET
 1)

(RPAQ? BOOLE-1
 2)

(RPAQ? BOOLE-2
 3)

(RPAQ? BOOLE-C1
 4)

(RPAQ? BOOLE-C2
 5)

(RPAQ? BOOLE-AND
 6)

(RPAQ? BOOLE-IOR
 7)

(RPAQ? BOOLE-XOR
 8)

(RPAQ? BOOLE-EQV
 9)

(RPAQ? BOOLE-NAND
 10)

(RPAQ? BOOLE-NOR
 11)

(RPAQ? BOOLE-ANDC1
 12)

(RPAQ? BOOLE-ANDC2
 13)

(RPAQ? BOOLE-ORC1
 14)

(RPAQ? 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 (INTEGER COUNT)
                                    (* kbr: "12-Jul-86 18:05")

    (COND
       ((ILEQ COUNT 0)
        (COND
           ((EQ COUNT 0)
            INTEGER)
           (T (RSH INTEGER (IMINUS COUNT)))))
       ((EQ INTEGER 0)
        0)
       ((IGREATERP COUNT (CONSTANT (INTEGERLENGTH MAX.FIXP)))
        (\BIGNUM.LSH INTEGER COUNT))
       (T (FRPTQ COUNT (SETQ INTEGER (IPLUS INTEGER INTEGER)))
          INTEGER))))
)
(DEFINEQ

(LOGCOUNT

  (CL:LAMBDA (INTEGER)
                                       (* kbr: "12-Jul-86 18:05")

                                                             (* Logcount returns the number of bits 

                                                             that are the complement of the sign in 

                                                             the integer argument x.

                                                             *)

                                                             (* If INTEGER is negative, then the 

                                                             number of 0 bits is returned, 

                                                             otherwise number of 1 bits is 

                                                             returned. *)

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

(%%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 (INTEGER)
                                          (* kbr: "12-Jul-86 18:05")

    (COND
       ((<
 INTEGER 0)
        (SETQ INTEGER (-
 -1 INTEGER))))
    (MACROLET ((NBITS.OR.LESS (INTEGER N)
                      (BQUOTE (<
 (\, INTEGER)
                               (\, (ASH
 1 N))))))
           (COND
              ((NBITS.OR.LESS INTEGER 16)
               (COND
                  ((NBITS.OR.LESS INTEGER 8)
                   (COND
                      ((NBITS.OR.LESS INTEGER 4)
                       (COND
                          ((NBITS.OR.LESS INTEGER 2)
                           (COND
                              ((NBITS.OR.LESS INTEGER 1)
                               (COND
                                  ((EQ INTEGER 0)
                                   0)
                                  (T 1)))
                              (T 2)))
                          ((NBITS.OR.LESS INTEGER 3)
                           3)
                          (T 4)))
                      ((NBITS.OR.LESS INTEGER 6)
                       (COND
                          ((NBITS.OR.LESS INTEGER 5)
                           5)
                          (T 6)))
                      ((NBITS.OR.LESS INTEGER 7)
                       7)
                      (T 8)))
                  ((NBITS.OR.LESS INTEGER 12)
                   (COND
                      ((NBITS.OR.LESS INTEGER 10)
                       (COND
                          ((NBITS.OR.LESS INTEGER 9)
                           9)
                          (T 10)))
                      ((NBITS.OR.LESS INTEGER 11)
                       11)
                      (T 12)))
                  ((NBITS.OR.LESS INTEGER 14)
                   (COND
                      ((NBITS.OR.LESS INTEGER 13)
                       13)
                      (T 14)))
                  ((NBITS.OR.LESS INTEGER 15)
                   15)
                  (T 16)))
              (T (+
 16 (INTEGER-LENGTH
 (ASH
 INTEGER -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: "14-Aug-86 13:13")

         (LOGOR (LOGANDC2
 INTEGER (MASK.1'S (fetch
 (BYTESPEC BYTESPEC.POSITION) of
 BYTESPEC)
                                         (fetch
 (BYTESPEC BYTESPEC.SIZE) of
 BYTESPEC)))
                (LSH NEWBYTE (fetch
 (BYTESPEC BYTESPEC.POSITION) of
 BYTESPEC)))))
)
(DECLARE: EVAL@COMPILE DONTCOPY 
(FILESLOAD (LOADCOMP)
       LLFLOAT LLCODE 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 FLOAT LCM %%GCD CL:GCD / 
                CL:* - + >= <= > < /= = PLUSP ODDP EVENP CL:ZEROP %%COMPLEX-PRINT %%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* 
                %%BUILD-RATIO RATIONALIZE RATIONAL DENOMINATOR NUMERATOR %%SIGNUM SIGNUM PHASE PRIMEP 
                ISQRT)
)
(PUTPROPS CMLARITH COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (12297 16392 (ISQRT 12307 . 13733) (PRIMEP 13735 . 14635) (PHASE 14637 . 15206) (SIGNUM 
15208 . 16073) (%%SIGNUM 16075 . 16390)) (16775 32323 (NUMERATOR 16785 . 17173) (DENOMINATOR 17175 . 
17564) (RATIONALP 17566 . 17729) (RATIONAL 17731 . 19164) (RATIONALIZE 19166 . 20064) (%%RATIO-PRINT 
20066 . 21652) (%%BUILD-RATIO 21654 . 22734) (%%RATIONALIZE-FLOAT 22736 . 26762) (%%RATIO* 26764 . 
27400) (%%RATIO/ 27402 . 27907) (%%RATIO-TIMES-QUOTIENT 27909 . 28611) (%%RATIO+ 28613 . 29038) (
%%RATIO- 29040 . 29119) (%%RATIO-PLUS-DIFFERENCE 29121 . 30347) (%%RATIO-INTEGER* 30349 . 31289) (
%%RATIO-INTEGER+ 31291 . 31769) (%%RATIO-INTEGER- 31771 . 32321)) (32751 37508 (COMPLEX 32761 . 33838)
 (REALPART 33840 . 34050) (IMAGPART 34052 . 34289) (%%COMPLEX+ 34291 . 34551) (%%COMPLEX- 34553 . 
34816) (%%COMPLEX* 34818 . 35266) (%%COMPLEX/ 35268 . 36010) (%%COMPLEX-ABS 36012 . 36297) (
%%COMPLEX-MINUS 36299 . 36506) (%%COMPLEX-TIMESI 36508 . 36898) (CONJUGATE 36900 . 37190) (
%%COMPLEX-PRINT 37192 . 37506)) (37640 37788 (NEW-MINUSP 37650 . 37786)) (37870 38019 (CL:ZEROP 37880
 . 38017)) (38020 38478 (EVENP 38030 . 38182) (ODDP 38184 . 38341) (PLUSP 38343 . 38476)) (38530 42429
 (%%= 38540 . 40997) (%%> 40999 . 42427)) (42430 46989 (= 42440 . 42615) (%%= 42617 . 45074) (/= 45076
 . 45356) (< 45358 . 45765) (> 45767 . 46151) (<= 46153 . 46555) (>= 46557 . 46987)) (53846 58650 (+ 
53856 . 54482) (- 54484 . 54985) (CL:* 54987 . 55421) (/ 55423 . 55715) (%%/ 55717 . 58392) (1+ 58394
 . 58520) (1- 58522 . 58648)) (61078 65467 (CL:GCD 61088 . 62498) (%%GCD 62500 . 64000) (LCM 64002 . 
65465)) (65644 67669 (FLOAT 65654 . 65894) (\FLOAT 65896 . 67667)) (67747 76324 (CL:FLOOR 67757 . 
68925) (TRUNCATE 68927 . 71138) (CEILING 71140 . 72233) (ROUND 72235 . 73950) (CL:MOD 73952 . 74452) (
REM 74454 . 74881) (FFLOOR 74883 . 75242) (FCEILING 75244 . 75603) (FTRUNCATE 75605 . 75967) (FROUND 
75969 . 76322)) (76359 79758 (DECODE-FLOAT 76369 . 77275) (SCALE-FLOAT 77277 . 78093) (FLOAT-RADIX 
78095 . 78262) (FLOAT-SIGN 78264 . 78515) (FLOAT-DIGITS 78517 . 78745) (FLOAT-PRECISION 78747 . 78959)
 (INTEGER-DECODE-FLOAT 78961 . 79756)) (80315 81572 (NEW-LESSP 80325 . 80455) (NEW-EQP 80457 . 80702) 
(NEW-ABS 80704 . 81438) (NEW-MINUS 81440 . 81570)) (92847 101097 (NEW-SLOWIPLUS2 92857 . 94403) (
NEW-SLOWIDIFFERENCE 94405 . 96718) (NEW-SLOWITIMES2 96720 . 100215) (NEW-SLOWIQUOTIENT 100217 . 100401
) (NEW-IREMAINDER 100403 . 100556) (NEW-SLOWIGREATERP 100558 . 101095)) (102146 110389 (%%+ 102156 . 
103997) (%%- 103999 . 105938) (%%* 105940 . 107710) (%%/ 107712 . 110387)) (110847 113134 (LOGIOR 
110857 . 111787) (LOGEQV 111789 . 112160) (LOGNAND 112162 . 112317) (LOGNOR 112319 . 112472) (LOGANDC1
 112474 . 112646) (LOGANDC2 112648 . 112804) (LOGORC1 112806 . 112976) (LOGORC2 112978 . 113132)) (
113181 114025 (BOOLE 113191 . 114023)) (114487 114844 (LOGTEST 114497 . 114674) (LOGBITP 114676 . 
114842)) (114845 115318 (ASH 114855 . 115316)) (115319 117702 (LOGCOUNT 115329 . 116797) (%%LOGCOUNT 
116799 . 117700)) (117703 119776 (INTEGER-LENGTH 117713 . 119774)) (119900 120269 (BYTE-SIZE 119910 . 
120084) (BYTE-POSITION 120086 . 120267)) (120335 120834 (LDB-TEST 120345 . 120530) (MASK-FIELD 120532
 . 120832)) (120900 121317 (DEPOSIT-FIELD 120910 . 121315)))))
STOP