(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(FILECREATED "16-May-90 18:47:56" |{DSK}<usr>local>lde>lispcore>sources>LLARITH.;2|
 74517  

      |changes| |to:|  (VARS LLARITHCOMS)

      |previous| |date:| "29-Dec-89 17:06:53" |{DSK}<usr>local>lde>lispcore>sources>LLARITH.;1|)


; Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
; The following program was created in 1982 but has not been published
; within the meaning of the copyright law, is furnished under license,
; and may not be used, copied and/or disclosed except in accordance
; with the terms of said license.

(PRETTYCOMPRINT LLARITHCOMS)

(RPAQQ LLARITHCOMS

       ((COMS                                                (* \; "OPCODES")

              (FNS IDIFFERENCE IGREATERP IQUOTIENT)
              
              (* |;;| 

            "\\slowplus2 \\slowdifference \\slowtimes2 \\slowquotient are redefined in cmlarith")


              (FNS \\SLOWIPLUS2 \\SLOWPLUS2 \\SLOWIDIFFERENCE \\SLOWDIFFERENCE \\SLOWIGREATERP 
                   \\SLOWLLSH1 \\SLOWLLSH8 \\SLOWLOGAND2 \\SLOWLOGOR2 \\SLOWLOGXOR2 \\SLOWLRSH1 
                   \\SLOWLRSH8 \\SLOWITIMES2 \\SLOWTIMES2 \\SLOWIQUOTIENT \\SLOWQUOTIENT))
        (COMS                                                (* \; 

                                     "IPLUS and IDIFFERENCE that smash result into their first arg")

              (FNS \\BOXIPLUS \\BOXIDIFFERENCE))
                                                             (* \; "subfunctions")

        (FNS \\MAKENUMBER)
        (FNS OVERFLOW)
        (INITVARS (\\OVERFLOW T))
        (CONSTANTS (MAX.SMALLP 65535)
               (MIN.SMALLP -65536)
               (MAX.FIXP 2147483647)
               (MIN.FIXP -2147483648)
               (\\SIGNBIT 32768))
        (FNS \\GETBASEFIXP \\PUTBASEFIXP \\PUTBASEFIXP.UFN)
        (EXPORT (DECLARE\: DONTCOPY (RECORDS FIXP)
                       (CONSTANTS (MAX.SMALL.INTEGER 65535)
                              (MAX.POS.HINUM 32767))
                       
                       (* |;;| "Unbox changed to handle ratios")


                       (MACROS .UNBOX. .NEGATE. .LLSH1. .LRSH1. .BOXIPLUS.)))
        (DECLARE\: DONTCOPY (MACROS OLD.UNBOX.))
        
        (* |;;| "Eqp modified to be like =")


        (FNS EQP FIX IQUOTIENT IREMAINDER LLSH LRSH LSH RSH \\RSH)
        (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS NBITS.OR.LESS .SUBSMALL. \\IQUOTREM))
                                                             (* \; 

                                                         "Machine independent arithmetic functions")

        
        (* |;;| "MINUSP redefined in cmlarith ")


        (FNS MINUSP ILESSP IMINUS IPLUS ITIMES LOGAND LOGOR LOGXOR SUB1 ZEROP ADD1 GCD IEQP 
             INTEGERLENGTH)
        
        (* |;;| "abs, difference, greaterp, plus, lessp, and times  redefined in cmlarith. ")


        
        (* |;;| "quotient and minus modified to handle ratios")


        
        (* |;;| "remainder remains as is")


        (FNS ABS DIFFERENCE GREATERP PLUS QUOTIENT REMAINDER LESSP MINUS TIMES)
        (FNS FMINUS FREMAINDER)
        (FNS RANDSET RAND EXPT)
        (DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (RANDSTATE)
                                              (\\TOL 9.9999925E-6)))
        (GLOBALVARS RANDSTATE \\TOL)
        (COMS (FNS |PutUnboxed| \\PUTFIXP \\PUTSWAPPEDFIXP \\HINUM \\LONUM)
              (EXPORT (DECLARE\: DONTCOPY (MACROS |PutUnboxed|))))
        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA MIN MAX IMIN IMAX FMIN FMAX TIMES PLUS LOGXOR LOGOR LOGAND ITIMES IPLUS))
               )
        
        (* |;;| "ODDP redefined in cmlarith")


        (COMS (FNS POWEROFTWOP IMOD ODDP)
              (DECLARE\: DONTCOPY (MACROS .2^NP.)))
        (COMS                                                (* \; "MIN and MAX")

              (FNS FLESSP FMAX FMIN GEQ IGEQ ILEQ IMAX IMIN LEQ MAX MIN)
              (DECLARE\: EVAL@COMPILE (ADDVARS (GLOBALVARS MAX.INTEGER MIN.INTEGER MAX.FLOAT 
                                                      MIN.FLOAT))))
        (DECLARE\: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (LOCALVARS . T))))



(* \; "OPCODES")


(DEFINEQ

(idifference

  (lambda (x y)
                                              (* |lmm| "11-FEB-82 14:02")

    ((opcodes idifference)
     x y)))

(igreaterp

  (lambda (x y)
                                              (* |lmm| "11-FEB-82 14:02")

    ((opcodes igreaterp
)
     x y)))

(iquotient

  (lambda (x y)
                                              (* |lmm| "11-FEB-82 14:02")

    ((opcodes iquotient)
     x y)))
)



(* |;;| "\\slowplus2 \\slowdifference \\slowtimes2 \\slowquotient are redefined in cmlarith")


(DEFINEQ

(\\slowiplus2

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:23 by jop")

    (\\callme 'iplus)
    (prog (hx lx hy ly signx)
          (.unbox. x hx lx (go retbig))
          (.unbox. 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))
                   (neq 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)))))

(\\slowplus2

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:24 by jop")

          
          (* |;;| "UFN for PLUS Microcode generally handles the case of two args both FIXPs")


    (\\callme 'plus)
    (prog nil
      lp  (return (cond
                     ((or (floatp x)
                          (floatp y))
                      (fplus x y))
                     ((not (fixp x))
                      (setq x (lisperror "NON-NUMERIC ARG" x t))
                      (go lp))
                     ((not (fixp y))
                      (setq y (lisperror "NON-NUMERIC ARG" y t))
                      (go lp))
                     (t (iplus
 x y)))))))

(\\slowidifference

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:24 by jop")

    (\\callme 'idifference)
    (prog (hx lx hy ly signx)
          (.unbox. x hx lx (go retbig))
          (.unbox. 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))
                         (neq signx (igreaterp
 hx max.pos.hinum)))))
              (go retbig)))
          (return (\\makenumber
 hx lx))
      retbig
          (return (\\bignum.difference x y)))))

(\\slowdifference

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:24 by jop")

          
          (* |;;| "UFN for DIFFERENCE Microcode generally handles the case of two args both FIXPs")


    (\\callme 'difference)
    (prog nil
      lp  (return (cond
                     ((or (floatp x)
                          (floatp y))
                      (fdifference x y))
                     ((not (fixp x))
                      (setq x (lisperror "NON-NUMERIC ARG" x t))
                      (go lp))
                     ((not (fixp y))
                      (setq y (lisperror "NON-NUMERIC ARG" y t))
                      (go lp))
                     (t (idifference
 x y)))))))

(\\slowigreaterp

  (lambda (x y)
                                              (* |lmm| "12-Apr-85 07:35")

    (\\callme 'igreaterp)
    (prog (hx lx hy ly)
          (.unbox. x hx lx (go retbig))
          (.unbox. 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))))))

(\\slowllsh1

  (lambda (x)
                                                (* |lmm| "13-OCT-82 15:27")

    (prog (lo hi)
          (.unbox. x hi lo)
          (return (\\makenumber
 (iplus
 (llsh
 (logand
 hi 32767)
                                             1)
                                       (cond
                                          ((igreaterp
 lo 32767)
                                           1)
                                          (t 0)))
                         (llsh
 (logand
 lo 32767)
                               1))))))

(\\slowllsh8

  (lambda (x)
                                                (* |lmm| "13-OCT-82 15:28")

    (prog (hi lo)
          (.unbox. x hi lo)
          (return (\\makenumber
 (iplus
 (llsh
 (logand
 hi 255)
                                             8)
                                       (lrsh
 lo 8))
                         (llsh
 (logand
 lo 255)
                               8))))))

(\\slowlogand2

  (lambda (x y)
                                              (* |lmm| "12-Apr-85 07:44")

    (\\callme 'logand)
    (prog (xh xl yh yl)
          (.unbox. x xh xl (go retbig))
          (.unbox. y yh yl (go retbig))
          (return (\\makenumber
 (logand
 xh yh)
                         (logand
 xl yl)))
      retbig
          (return (\\bignum.logand x y)))))

(\\slowlogor2

  (lambda (x y)
                                              (* |lmm| "12-Apr-85 07:48")

    (\\callme 'logor)
    (prog (xh xl yh yl)
          (.unbox. x xh xl (go retbig))
          (.unbox. y yh yl (go retbig))
          (return (\\makenumber
 (logor
 xh yh)
                         (logor
 xl yl)))
      retbig
          (return (\\bignum.logor x y)))))

(\\slowlogxor2

  (lambda (x y)
                                              (* |lmm| "12-Apr-85 07:51")

    (\\callme 'logxor)
    (prog (xh xl yh yl)
          (.unbox. x xh xl (go retbig))
          (.unbox. y yh yl (go retbig))
          (return (\\makenumber
 (logxor
 xh yh)
                         (logxor
 xl yl)))
      retbig
          (return (\\bignum.logxor x y)))))

(\\slowlrsh1

  (lambda (x)
                                                (* |JonL| "27-Sep-84 22:59")

    (prog (hi lo)
          (.unbox. x hi lo)
          (return (\\makenumber
 (lrsh
 hi 1)
                         (iplus
 (lrsh
 lo 1)
                                (cond
                                   ((eq 0 (logand
 hi 1))
                                    0)
                                   (t 32768))))))))

(\\slowlrsh8

  (lambda (x)
                                                (* |lmm| "13-OCT-82 15:29")

    (prog (hi lo)
          (.unbox. x hi lo)
          (return (\\makenumber
 (lrsh
 hi 8)
                         (iplus
 (llsh
 (logand
 hi 255)
                                      8)
                                (lrsh
 lo 8)))))))

(\\slowitimes2

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:26 by jop")

    (\\callme 'itimes)
    (cond
       ((or (eq x 0)
            (eq y 0))
        0)
       (t (prog (hx hy lx ly sign (hr 0)
                    (lr 0)
                    carry)
                (.unbox. x hx lx (go retbig))
                (.unbox. y hy ly (go retbig))
                (cond
                   ((igreaterp
 hx max.pos.hinum)
                    (|if|
 (equal x min.fixp)
                        |then|
 (go retbig))
                    (.negate. hx lx)
                    (setq sign t)))
                (cond
                   ((igreaterp
 hy max.pos.hinum)
                    (|if|
 (equal y min.fixp)
                        |then|
 (go retbig))
                    (.negate. hy ly)
                    (setq sign (not sign))))
                (cond
                   ((neq hy 0)
                    (cond
                       ((neq hx 0)
                        (go over)))
                    (|swap|
 lx ly)
                    (|swap|
 hx hy)))
            mlp (cond
                   ((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)))))))

(\\slowtimes2

  (lambda (x y)
                                              (* |lmm| "21-Aug-84 16:22")

          
          (* ufn |for| times |Microcode| |generally| |handles| |the| |case| |of| |two| 

          |args| |both| fixp\s)


    (\\callme 'times)
    (prog nil
      lp  (return (cond
                     ((or (floatp x)
                          (floatp y))
                      (ftimes x y))
                     ((not (fixp x))
                      (setq x (lisperror "NON-NUMERIC ARG" x t))
                      (go lp))
                     ((not (fixp y))
                      (setq y (lisperror "NON-NUMERIC ARG" y t))
                      (go lp))
                     (t (itimes
 x y)))))))

(\\slowiquotient

  (lambda (x y)
                                              (* |lmm| " 2-Jul-84 17:12")

    (\\callme 'iquotient)
    (\\iquotrem x y x)
    x))

(\\slowquotient

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:26 by jop")

          
          (* |;;| "UFN for QUOTIENT Microcode generally handles the case of two args both FIXPs")


    (\\callme 'quotient)
    (prog nil
      lp  (return (cond
                     ((or (floatp x)
                          (floatp y))
                      (fquotient x y))
                     ((not (fixp x))
                      (setq x (lisperror "NON-NUMERIC ARG" x t))
                      (go lp))
                     ((not (fixp y))
                      (setq y (lisperror "NON-NUMERIC ARG" y t))
                      (go lp))
                     (t (iquotient
 x y)))))))
)



(* \; "IPLUS and IDIFFERENCE that smash result into their first arg")


(DEFINEQ

(\\boxiplus

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:27 by jop")

          
          (* |;;| "UFN for BOXIPLUS ipcode")


    (.boxiplus. x y)))

(\\boxidifference

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:27 by jop")

    (prog ((hx (\\getbase x 0))
           (lx (\\getbase x 1))
           hy ly)
          (.unbox. y hy ly)
          (.negate. hy ly)
          (setq hx (cond
                      ((igreaterp
 hx (idifference
 max.small.integer hy))
                       (idifference
 hx (add1
 (idifference
 max.small.integer hy))))
                      (t (iplus
 hx hy))))                    (* \; "Add high parts")

          (\\putbase x 1 (cond
                            ((igreaterp
 lx (idifference
 max.small.integer ly))
                                                             (* \; "Carry into high part.")

                             (setq hx (cond
                                         ((eq hx max.small.integer)
                                          0)
                                         (t (add1
 hx))))
                             (idifference
 lx (add1
 (idifference
 max.small.integer ly))))
                            (t (iplus
 lx ly))))
          (\\putbase x 0 hx)
          (return x))))
)



(* \; "subfunctions")


(DEFINEQ

(\\makenumber

  (lambda (n0 n1)
                                            (* \; "Edited  8-Apr-87 11:28 by jop")

          
          (* |;;| "used as punt case for arith opcodes which create large numbers")


    (setq n1 (.coerce.to.smallposp. n1))
    (selectc (setq n0 (.coerce.to.smallposp. n0))
        (0 n1)
        (65535                                               (* \; "This is a word's worth of 1 bits")

               (\\vag2 |\\SmallNegHi| n1))
        (|create|
 fixp
               hinum _ n0
               lonum _ n1))))
)
(DEFINEQ

(overflow

  (lambda (flg)                                              (* |lmm:| 14-jan-76 1 6)

    (prog1 \\overflow (setq \\overflow (selectq flg
                                           (nil nil)
                                           (t t)
                                           0)))))
)

(RPAQ? \\OVERFLOW
 T)
(DECLARE\: EVAL@COMPILE 

(RPAQQ MAX.SMALLP
 65535)

(RPAQQ MIN.SMALLP
 -65536)

(RPAQQ MAX.FIXP
 2147483647)

(RPAQQ MIN.FIXP
 -2147483648)

(RPAQQ \\SIGNBIT
 32768)


(CONSTANTS (MAX.SMALLP 65535)
       (MIN.SMALLP -65536)
       (MAX.FIXP 2147483647)
       (MIN.FIXP -2147483648)
       (\\SIGNBIT 32768))
)
(DEFINEQ

(\\getbasefixp

  (lambda (base offst)
                                       (* |lmm| " 5-Jan-85 23:11")

    ((lambda (|\\NewBaseAddr|)
       (\\makenumber
 (\\getbase |\\NewBaseAddr| 0)
              (\\getbase |\\NewBaseAddr| 1)))
     (\\addbase base offst))))

(\\putbasefixp

  (lambda (base offst val)
                                   (* |lmm| " 5-Jan-85 23:16")

    (prog (hi lo)
          (.xunbox. val hi lo)
          (\\putbase base offst hi)
          (\\putbase base (add1
 offst)
                 lo)
      val (return val))))

(\\putbasefixp.ufn

  (lambda (base val offst)
                                   (* |lmm| " 5-Jan-85 23:25")

    (prog (hi lo)
          (.xunbox. val hi lo)
          (\\putbase base offst hi)
          (\\putbase base (add1
 offst)
                 lo)
      val (return val))))
)
(* "FOLLOWING DEFINITIONS EXPORTED")

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

(BLOCKRECORD FIXP
 ((HINUM WORD)
                       (LONUM WORD))
                      (CREATE
 (CREATECELL \\FIXP))
                      (TYPE?
 (EQ (NTYPX DATUM)
                                     \\FIXP)))
)

(DECLARE\: EVAL@COMPILE 

(RPAQQ MAX.SMALL.INTEGER
 65535)

(RPAQQ MAX.POS.HINUM
 32767)


(CONSTANTS (MAX.SMALL.INTEGER 65535)
       (MAX.POS.HINUM 32767))
)

(DECLARE\: EVAL@COMPILE 

(PUTPROPS .UNBOX.
 MACRO

          (ARGS (LET ((ARG-FORM (CAR ARGS))
                      (HIGH-VAR (CADR ARGS))
                      (LOW-VAR (CADDR ARGS))
                      (BIGNUM-FORM (CADDDR ARGS)))
                     `(PROG NIL
                        UBLP
                            (SELECTC (NTYPX ,ARG-FORM)
                                (\\FIXP (SETQ ,HIGH-VAR (|ffetch|
 (FIXP HINUM)
                                                           |of|
 ,ARG-FORM))
                                        (SETQ ,LOW-VAR (|ffetch|
 (FIXP LONUM) |of|

                                                                                  ,ARG-FORM)))
                                (\\SMALLP (COND
                                             ((ILEQ
 0 ,ARG-FORM)
                                              (SETQ ,HIGH-VAR 0)
                                              (SETQ ,LOW-VAR ,ARG-FORM))
                                             (T (SETQ ,HIGH-VAR 65535)
                                                (SETQ ,LOW-VAR (\\LOLOC ,ARG-FORM)))))
                                (\\FLOATP (SETQ ,ARG-FORM (\\FIXP.FROM.FLOATP ,ARG-FORM))
                                          (GO UBLP))
                                (COND
                                   ((TYPENAMEP ,ARG-FORM 'RATIO)
                                    (SETQ ,ARG-FORM (IQUOTIENT
 (CL::RATIO-NUMERATOR ,ARG-FORM)
                                                           (CL::RATIO-DENOMINATOR ,ARG-FORM)))
                                    (GO UBLP))
                                   ,@(COND
                                        (BIGNUM-FORM `(((CL:INTEGERP ,ARG-FORM)
                                                        ,BIGNUM-FORM)))
                                        (T `(((CL:INTEGERP ,ARG-FORM)
                                              (\\ILLEGAL.ARG ,ARG-FORM)))))
                                   (T (CL::%NOT-NONCOMPLEX-NUMBER-ERROR ,ARG-FORM))))))))

(PUTPROPS .NEGATE.
 MACRO
 ((HY LY)
                                  (COND
                                     ((EQ 0 LY)
                                      (AND (NEQ HY 0)
                                           (SETQ HY (ADD1
 (IDIFFERENCE
 MAX.SMALL.INTEGER HY))
                                            )))
                                     (T (SETQ HY (IDIFFERENCE
 MAX.SMALL.INTEGER HY))
                                        (SETQ LY (ADD1
 (IDIFFERENCE
 MAX.SMALL.INTEGER LY)))))
                                  ))

(PUTPROPS .LLSH1.
 MACRO
 ((HI LO)                     (* \; 

                                                    "shift the pair left one, assuming no overflow")

                                 (SETQ HI (LLSH
 HI 1))
                                 (SETQ LO (LLSH
 (COND
                                                       ((IGREATERP
 LO MAX.POS.HINUM)
                                                        (|add|
 HI 1)
                                                        (LOGAND
 LO MAX.POS.HINUM))
                                                       (T LO))
                                                 1))))

(PUTPROPS .LRSH1.
 MACRO
 ((HI LO)
                                 (SETQ LO (LRSH
 LO 1))
                                 (COND
                                    ((NEQ (LOGAND
 HI 1)
                                          0)
                                     (SETQ LO (IPLUS
 LO \\SIGNBIT))))
                                 (SETQ HI (LRSH
 HI 1))))

(PUTPROPS .BOXIPLUS.
 MACRO
 (OPENLAMBDA (X Y)
                                          (PROG ((HX (\\GETBASE X 0))
                                                 (LX (\\GETBASE X 1))
                                                 HY LY)
                                                (.UNBOX. Y HY LY)
                                                (SETQ HX (COND
                                                            ((IGREATERP
 HX (IDIFFERENCE

                                                                                MAX.SMALL.INTEGER HY)
                                                                    )
                                                             (IDIFFERENCE
 HX
                                                                    (ADD1
 (IDIFFERENCE
 
                                                                                    MAX.SMALL.INTEGER
                                                                                     HY))))
                                                            (T (IPLUS
 HX HY))))
                                                             (* |Add| |high| |parts|)

                                                (\\PUTBASE X 1 (COND
                                                                  ((IGREATERP
 LX (IDIFFERENCE

                                                                                      
                                                                                    MAX.SMALL.INTEGER
                                                                                      LY))
                                                             (* |Carry| |into| |high| |part.|)

                                                                   (SETQ HX (COND
                                                                               ((EQ HX 
                                                                                    MAX.SMALL.INTEGER
                                                                                    )
                                                                                0)
                                                                               (T (ADD1
 HX))))
                                                                   (IDIFFERENCE

                                                                    LX
                                                                    (ADD1
 (IDIFFERENCE
 
                                                                                    MAX.SMALL.INTEGER
                                                                                     LY))))
                                                                  (T (IPLUS
 LX LY))))
                                                (\\PUTBASE X 0 HX)
                                                (RETURN X))))
)
)

(* "END EXPORTED DEFINITIONS")

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

(PUTPROPS OLD.UNBOX.
 MACRO
 ((V HV LV BIGNUMFORM)
                                    (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))
                                              (|if|
 (TYPENAMEP V 'BIGNUM)
                                                  |then|
 (|if|
 'BIGNUMFORM
                                                                 |then|
 BIGNUMFORM
                                                               |else|
 (SETQ V
                                                                           (\\LISPERROR V 
                                                                                  "ARG NOT FIXP" T))
                                                                     (GO UBLP))
                                                |else|
 (SETQ V (LISPERROR "NON-NUMERIC ARG" V T))
                                                      (GO UBLP))))))
)
)



(* |;;| "Eqp modified to be like =")


(DEFINEQ

(EQP

  (LAMBDA (X Y)
                                          (* \; "Edited  7-Dec-88 09:04 by jds")

    (COND
       ((EQ X Y)
        T)
       ((AND (FIXP X)
             (FIXP Y))
        (IEQP
 X Y))
       ((AND (OR (FLOATP X)
                 (FIXP X))
             (OR (FLOATP Y)
                 (FIXP Y)))
        (FEQP X Y))
       ((AND (NUMBERP X)
             (NUMBERP Y))
        (= X Y))
       (T (\\EXTENDED.EQP X Y)))))

(fix

  (lambda (n)
                                                (* \; "Edited  8-Apr-87 11:30 by jop")

          
          (* |;;| "FIX compiles open")


    (iplus
 n 0)))

(iquotient

  (lambda (x y)
                                              (* |lmm| "11-FEB-82 14:02")

    ((opcodes iquotient)
     x y)))

(iremainder

  (lambda (x y)
                                              (* |edited:| "29-APR-82 05:01")

    (\\iquotrem x y nil y)
    y))

(llsh

  (lambda (x n)
                                              (* |lmm| "13-OCT-82 15:30")

    (cond
       ((igreaterp
 0 n)
        (lrsh
 x (iminus
 n)))
       (t (prog (xhi xlo)
                (.unbox. x xhi xlo)
                (cond
                   ((igreaterp
 n 31)
                    (return 0)))
                (cond
                   ((igreaterp
 n 15)
                    (setq xhi xlo)
                    (setq xlo 0)
                    (setq n (idifference
 n 16))))
                (cond
                   ((igreaterp
 n 7)
                    (setq xhi (iplus
 (llsh
 (logand
 xhi 255)
                                           8)
                                     (lrsh
 xlo 8)))
                    (setq xlo (llsh
 (logand
 xlo 255)
                                    8))
                    (setq n (idifference
 n 8))))
                (frptq n (setq xhi (logand
 xhi max.pos.hinum))
                       (.llsh1. xhi xlo))
                (return (\\makenumber
 xhi xlo)))))))

(lrsh

  (lambda (x n)
                                              (* \; "Edited  8-Apr-87 11:30 by jop")

          
          (* |;;| 

          "assumes case where n is constant and 8 or 1 handled in microcode or by \\SLOWLRSHn")


    (cond
       ((igreaterp
 0 n)
        (llsh
 x (iminus
 n)))
       (t (prog (xhi xlo)
                (.unbox. x xhi xlo)
                (cond
                   ((igreaterp
 n 31)
                    (return 0)))
                (cond
                   ((igreaterp
 n 15)
                    (setq xlo xhi)
                    (setq xhi 0)
                    (setq n (idifference
 n 16))))
                (cond
                   ((igreaterp
 n 7)
                    (setq xlo (iplus
 (lrsh
 xlo 8)
                                     (llsh
 (logand
 xhi 255)
                                           8)))
                    (setq xhi (lrsh
 xhi 8))
                    (setq n (idifference
 n 8))))
                (frptq n (.lrsh1. xhi xlo))
                (return (\\makenumber
 xhi xlo)))))))

(LSH

  (LAMBDA (X N)
                                          (* \; "Edited  7-Apr-89 16:19 by jds")


    (* |;;| "Arithmetic left shift.  Since this punts on the dorado, and RSH is optimized to be LSH for the Sun, we have to use \\RSH here (the bottoming-out version of RSH).")


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

(RSH

  (LAMBDA (X N)
                                          (* \; "Edited  7-Apr-89 16:20 by jds")


    (* |;;| "Arithmetic Right-shift.  There's an optimizer on this function, so just call the underlying implementation.")


    (\\RSH
 X N)))

(\\RSH

  (LAMBDA (X N)
                                          (* \; "Edited  7-Apr-89 16:21 by jds")


    (* |;;| 

 "This is the version of RSH where things bottom out if LSH doesn't handle all the possible cases.")


    (COND
       ((IGREATERP
 0 N)
        (LSH
 X (IMINUS
 N)))
       ((EQ X 0)
        0)
       (T (PROG (XHI XLO)
                (.UNBOX. X XHI XLO (GO RETBIG))
                (COND
                   ((IGREATERP
 N 31)
                    (RETURN (COND
                               ((IGREATERP
 XHI 32767)    (* \; "X WAS NEGATIVE")

                                -1)
                               (T 0)))))
                (COND
                   ((IGREATERP
 N 15)
                    (SETQ XLO XHI)
                    (SETQ XHI (COND
                                 ((IGREATERP
 XHI 32767)
                                  65535)
                                 (T 0)))
                    (SETQ N (IDIFFERENCE
 N 16))))
                (COND
                   ((IGREATERP
 N 7)
                    (SETQ XLO (IPLUS
 (LRSH
 XLO 8)
                                     (LLSH
 (LOGAND
 XHI 255)
                                            8)))
                    (SETQ XHI (IPLUS
 (LRSH
 XHI 8)
                                     (COND
                                        ((IGREATERP
 XHI 32767)
                                         65280)
                                        (T 0))))
                    (SETQ N (IDIFFERENCE
 N 8))))
                (FRPTQ N (SETQ XLO (IPLUS
 (LRSH
 XLO 1)
                                          (COND
                                             ((EQ 0 (LOGAND
 XHI 1))
                                              0)
                                             (T 32768))))
                       (SETQ XHI (IPLUS
 (LRSH
 XHI 1)
                                        (LOGAND
 XHI 32768))))
                (RETURN (\\MAKENUMBER
 XHI XLO))
            RETBIG
                (RETURN (\\BIGNUM.LSH X (IMINUS
 N))))))))
)
(DECLARE\: EVAL@COMPILE DONTCOPY 
(DECLARE\: EVAL@COMPILE 

(PUTPROPS NBITS.OR.LESS
 MACRO
 ((X N)
                                       (ILESSP
 X (CONSTANT (LLSH
 1 N)))))

(PUTPROPS .SUBSMALL.
 MACRO
 ((X Y)                    (* \; 

                                     "Subtract Y from X, returning the borrow out of the next word")

                                    (COND
                                       ((ILEQ
 Y X)
                                        (SETQ X (IDIFFERENCE
 X Y))
                                        0)
                                       (T (SETQ X (ADD1
 (IDIFFERENCE
 MAX.SMALL.INTEGER
                                                                   (IDIFFERENCE
 Y X))))
                                          1))))

(PUTPROPS \\IQUOTREM
 MACRO
 ((X Y QUO REM)
                                    (PROG (HX LX HY LY SIGNQUOTIENT SIGNREMAINDER (CNT 0)
                                              (HZ 0)
                                              (LZ 0))
                                          (.UNBOX. X HX LX (GO RETBIG))
                                          (.UNBOX. 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
                                             ('REM           (* \; "remainder is left in X")

                                                   (COND
                                                      (SIGNREMAINDER (.NEGATE. HX LX)))
                                                   (SETQ REM (\\MAKENUMBER
 HX LX))))
                                          (COND
                                             ('QUO (COND
                                                      (SIGNQUOTIENT (.NEGATE. HZ LZ)))
                                                   (SETQ QUO (\\MAKENUMBER
 HZ LZ))))
                                          (RETURN)
                                      DIVZERO
                                          (SELECTQ \\OVERFLOW
                                              (T (ERROR "DIVIDE BY ZERO" Y))
                                              (GO RET0))
                                      RET0
                                          (COND
                                             ('REM (SETQ REM 0)))
                                          (COND
                                             ('QUO (SETQ QUO 0)))
                                          (RETURN)
                                      RETBIG
                                          (|if|
 'QUO
                                              |then|
 (SETQ QUO (\\BIGNUM.QUOTIENT X Y)))
                                          (|if|
 'REM
                                              |then|
 (SETQ REM (\\BIGNUM.REMAINDER X Y)))
                                          (RETURN))))
)
)



(* \; "Machine independent arithmetic functions")





(* |;;| "MINUSP redefined in cmlarith ")


(DEFINEQ

(minusp

  (lambda (x)
                                                (* fs "22-Nov-86 20:47")

                                                             (* 

                                          "Replaced by Roach (via MOVD) in CMLARITH to handle RATIOS")

    (cond
       ((floatp x)
        (fgreaterp 0.0 x))
       (t (igreaterp
 0 x)))))

(ilessp

  (lambda (x y)
    (igreaterp
 y x)))

(iminus

  (lambda (x)
    (idifference
 0 x)))

(iplus

  (lambda n
                                                  (* \; "Edited  8-Apr-87 11:34 by jop")

          
          (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns IPLUS calls into sequences of opcodes")


    (selectq n
        (2 (iplus
 (arg n 1)
                  (arg n 2)))
        (1 (iplus
 (arg n 1)))
        (0 (iplus
))
        (prog ((r (iplus
 (arg n 1)
                         (arg n 2)
                         (arg n 3)))
               (j 4))
          lp  (cond
                 ((ileq
 j n)
                  (setq r (iplus
 r (arg n j)))
                  (setq j (add1
 j))
                  (go lp)))
              (return r)))))

(itimes

  (lambda n
                                                  (* \; "Edited  8-Apr-87 11:34 by jop")

          
          (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns ITIMES calls into sequences of opcodes")


    (selectq n
        (2 (itimes
 (arg n 1)
                  (arg n 2)))
        (1 (itimes
 (arg n 1)))
        (0 (itimes
))
        (prog ((r (itimes
 (arg n 1)
                         (arg n 2)
                         (arg n 3)))
               (j 4))
          lp  (cond
                 ((ileq
 j n)
                  (setq r (itimes
 r (arg n j)))
                  (setq j (add1
 j))
                  (go lp)))
              (return r)))))

(logand

  (lambda n
                                                  (* \; "Edited  8-Apr-87 11:34 by jop")

          
          (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGAND calls into sequences of opcodes")


    (selectq n
        (2 (logand
 (arg n 1)
                  (arg n 2)))
        (1 (logand
 (arg n 1)))
        (0 (logand
))
        (prog ((r (logand
 (arg n 1)
                         (arg n 2)
                         (arg n 3)))
               (j 4))
          lp  (cond
                 ((ileq
 j n)
                  (setq r (logand
 r (arg n j)))
                  (setq j (add1
 j))
                  (go lp)))
              (return r)))))

(logor

  (lambda n
                                                  (* \; "Edited  8-Apr-87 11:34 by jop")

          
          (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGOR calls into sequences of opcodes")


    (selectq n
        (2 (logor
 (arg n 1)
                  (arg n 2)))
        (1 (logor
 (arg n 1)))
        (0 (logor
))
        (prog ((r (logor
 (arg n 1)
                         (arg n 2)
                         (arg n 3)))
               (j 4))
          lp  (cond
                 ((ileq
 j n)
                  (setq r (logor
 r (arg n j)))
                  (setq j (add1
 j))
                  (go lp)))
              (return r)))))

(logxor

  (lambda n
                                                  (* \; "Edited  8-Apr-87 11:35 by jop")

          
          (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGXOR calls into sequences of opcodes")


    (selectq n
        (2 (logxor
 (arg n 1)
                  (arg n 2)))
        (1 (logxor
 (arg n 1)))
        (0 (logxor
))
        (prog ((r (logxor
 (arg n 1)
                         (arg n 2)
                         (arg n 3)))
               (j 4))
          lp  (cond
                 ((ileq
 j n)
                  (setq r (logxor
 r (arg n j)))
                  (setq j (add1
 j))
                  (go lp)))
              (return r)))))

(sub1

  (lambda (x)
                                                (* \; "Edited  8-Apr-87 11:35 by jop")

    (idifference
 x 1)))

(zerop

  (lambda (x)
                                                (* |Pavel| " 6-Oct-86 22:13")

    (cond
       ((eq x 0)
        t)
       ((floatp x)
        (\\fzerop x)))))

(add1

  (lambda (x)
                                                (* \; "Edited  8-Apr-87 11:35 by jop")

    (iplus
 x 1)))

(gcd

  (lambda (n1 n2)
                                            (* \; "Edited  8-Apr-87 11:35 by jop")

          
          (* |;;| "Greatest common divisor, using Euler's Method")


    (cond
       ((eq 0 n2)
        n1)
       ((minusp
 n2)                                          (* \; "GCD is always positive")

        (gcd
 (minus
 n2)
             n1))
       (t (gcd
 n2 (iremainder
 n1 n2))))))

(ieqp

  (lambda (x y)
                                              (* |JonL| " 1-May-84 22:23")

    (eq 0 (idifference
 x y))))

(integerlength

  (lambda (x)
                                                (* \; "Edited  8-Apr-87 11:37 by jop")

    (selectc (ntypx x)
        (\\smallp (cond
                     ((ilessp
 x 0)
                      (setq x (idifference
 0 x))))
                  (cond
                     ((nbits.or.less x 16)
                      (cond
                         ((nbits.or.less x 8)
                          (cond
                             ((nbits.or.less x 4)
                              (cond
                                 ((nbits.or.less x 2)
                                  (cond
                                     ((nbits.or.less x 1)
                                      (cond
                                         ((eq x 0)
                                          0)
                                         (t 1)))
                                     (t 2)))
                                 ((nbits.or.less x 3)
                                  3)
                                 (t 4)))
                             ((nbits.or.less x 6)
                              (cond
                                 ((nbits.or.less x 5)
                                  5)
                                 (t 6)))
                             ((nbits.or.less x 7)
                              7)
                             (t 8)))
                         ((nbits.or.less x 12)
                          (cond
                             ((nbits.or.less x 10)
                              (cond
                                 ((nbits.or.less x 9)
                                  9)
                                 (t 10)))
                             ((nbits.or.less x 11)
                              11)
                             (t 12)))
                         ((nbits.or.less x 14)
                          (cond
                             ((nbits.or.less x 13)
                              13)
                             (t 14)))
                         ((nbits.or.less x 15)
                          15)
                         (t 16)))
                     (t (shouldnt))))
        (\\fixp (prog ((hx (|fetch|
 (fixp hinum) |of|
 x)))
                      (cond
                         ((igreaterp
 hx max.pos.hinum)       (* \; "So X is negative")

                          ((lambda (lx)
                             (cond
                                ((and (eq hx \\signbit)
                                      (eq lx 0))             (* \; 

                                                            "So X is EQP to the minimum FIXP integer")

                                 (return (constant bits.per.fixp)))
                                (t (.negate. hx lx))))
                           (|fetch|
 (fixp lonum) |of|
 x))))
                      (return (cond
                                 ((eq hx 0)
          
          (* |;;| "This bizarre case shouldn't really happen, but I wouldn't like to rule it out -- a non-normalized FIXP that realy should be a SMALLP")


                                  (integerlength
 (|fetch|
 (fixp lonum) |of|
 x)))
                                 (t (iplus
 (integerlength
 hx)
                                           bitsperword))))))
        (cond
           ((typenamep x 'bignum)
            (\\bignum.integerlength x))
           (t (cl::%not-integer-error x))))))
)



(* |;;| "abs, difference, greaterp, plus, lessp, and times  redefined in cmlarith. ")





(* |;;| "quotient and minus modified to handle ratios")





(* |;;| "remainder remains as is")


(DEFINEQ

(abs

  (lambda (x)
                                                (* fs "22-Nov-86 20:58")

                                                             (* 

                                                             "Replaced in CMLARITH to handle RATIOS")

    (cl:ctypecase x ((or integer float)
                     (cond
                        ((< x 0)
                         (- 0 x))
                        (t x)))
           (ratio (cond
                     ((< (cl:numerator x)
                       0)
                      (%make-ratio (- 0 (cl:numerator x))
                             (cl:denominator x)))
                     (t x)))
           (complex (%complex-abs x)))))

(difference

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:39 by jop")

    ((opcodes difference)
     x y)))

(greaterp

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:39 by jop")

    (cond
       ((and (fixp x)
             (fixp y))
        (igreaterp
 x y))
       (t (fgreaterp x y)))))

(plus

  (lambda n
                                                  (* \; "Edited  8-Apr-87 11:39 by jop")

          
          (* |;;| "Microcode generally handles the case of two args both FIXPs")


    (prog (r (j 0))
      lp  (cond
             ((neq j n)
              (setq j (add1
 j))
              (setq r (cond
                         ((and (fixp (arg n j))
                               (not (floatp r)))
                          (iplus
 (or r 0)
                                 (arg n j)))
                         (t (fplus (or r 0.0)
                                   (arg n j)))))
              (go lp)))
          (return r))))

(quotient

  (lambda (x y)
                                              (* \; "Edited 12-Feb-87 14:59 by jop")

                                                             (* |lmm:| 17-dec-75 25 36)

    (cond
       ((and (fixp x)
             (fixp y))
        (iquotient
 x y))
       ((or (floatp x)
            (floatp y))
        (fquotient x y))
       (t (/ x y)))))

(remainder

  (lambda (x y)                                              (* |lmm:| 17-dec-75 21 30)

    (cond
       ((and (fixp x)
             (fixp y))
        (iremainder
 x y))
       (t (fremainder
 x y)))))

(lessp

  (lambda (x y)
                                              (* \; "Edited  8-Apr-87 11:40 by jop")

    (cond
       ((and (fixp y)
             (fixp x))
        (igreaterp
 y x))
       (t (fgreaterp y x)))))

(minus

  (lambda (x)
                                                (* \; "Edited  1-Mar-87 18:10 by jop")

    (cond
       ((floatp x)
        (fdifference 0.0 x))
       (t (difference
 0 x)))))

(times

  (lambda n
                                                  (* \; "Edited  8-Apr-87 11:40 by jop")

    (prog (r (j 0))
      lp  (cond
             ((neq j n)
              (setq j (add1
 j))
              (setq r (cond
                         ((and (fixp (arg n j))
                               (not (floatp r)))
                          (itimes
 (or r 1)
                                 (arg n j)))
                         (t (ftimes (or r 1.0)
                                   (arg n j)))))
              (go lp)))
          (return r))))
)
(DEFINEQ

(fminus

  (lambda (x)
                                                (* |lmm| " 5-MAR-80 23:12")

    (fdifference 0.0 x)))

(fremainder

  (lambda (x y)
                                              (* |rrb| "24-APR-80 10:37")

    (fdifference x (ftimes (float (fix
 (fquotient x y)))
                          y))))
)
(DEFINEQ

(randset

  (lambda (x)
                                                (* \; "Edited  8-Apr-87 11:40 by jop")

    (prog (rs rs1 rs2)
          (cond
             ((null x)
              (go out))
             ((eq x t)                                       (* \; "initialize with clock")

              (setq rs1 (clock))
              (setq rs2 (idate)))
             ((and (fixp (cdr (listp x)))
                   (fixp (car x)))                           (* \; 

                                                            "user supplies initialization, old-style")

              (setq rs1 (car x))
              (setq rs2 (cdr x)))
             ((and (eq (length x)
                       55)
                   (every x (function fixp)))
              (setq rs (mapcar x (function (lambda (n)
                                             (iplus
 n)))))
              (go xx))
             (t (error '"ARG NOT PREVIOUS VALUE OF RANDSET" x)))
          (prog ((\\overflow 0))
                (declare
 (specvars \\overflow))
                (setq rs
                 (mapcar '(53375 47430 1274 55702 61592 27723 11236 16824 35838 62289 11525 37822 
                                 34676 105 58750 27759 9988 4217 56951 30292 24550 1397 54588 54264 
                                 43300 3862 39006 11386 52259 1055 955 16320 19910 58470 3263 64657 
                                 1704 17373 56820 17255 51637 47962 26272 4464 2884 51773 39422 64835 
                                 57733 34919 5315 12110 15116 10133 10816)
                        (function (lambda (z)
                                    (setq rs1 (logand
 rs1 65535))
                                    (logxor
 z (setq rs2 (prog1 (logand
 (iplus
 (itimes
 rs1 19869)
                                                                              rs1)
                                                                      65535)
                                                               (setq rs1 rs2)))))))))
      xx  (frplacd (last rs)
                 rs)
          (setq randstate (cons rs (fnth rs 31)))
      out (return (|for|
 x |in|
 (car randstate) |as|
 i |from|
 1 |to|
 55 |collect|
 x)))))

(RAND

  (LAMBDA (LOWER UPPER)
                                      (* \; "Edited  3-Sep-87 19:03 by jds")

          
          (* |;;| "This function implements the XRAND subroutine described in Stanford memo STAN-CS-77-601, Analysis of Additive Random Number Generators, by John F.  Reiser, on p 28.0 Rather than storing the X values in an array and computing indexes I and J, however, I have elected to retain state in a circular list of 51 elements.  RANDSTATE is (CONS X (NTH X 31));  each time RAND is called, both CAR and CDR of RANDSTATE are CDR'ed to effectively increment the index.  In addition, the numbers are stored as 16 bit binary fractions (i.e.  the decimal point is on the left of the 16-bit quantity)")


    (PROG (I J)
          (OR (LISTP RANDSTATE)
              (PROGN (RANDSET
 T)
                     RANDSTATE))
          (SETQ I (CDAR RANDSTATE))
          (SETQ J (CDDR RANDSTATE))
          (RPLNODE RANDSTATE I J)
          (RPLACA I (LOGAND
 (IDIFFERENCE
 (CAR I)
                                   (CAR J))
                           MAX.SMALLP)))
    (COND
       ((NOT UPPER)
        (COND
           ((NULL LOWER)                                     (* \; 

                   "both UPPER and LOWER nil.  Return number (0 (\\, MAX.SMALLP)) --- not documented")


            (CAAR RANDSTATE))
           ((ZEROP
 LOWER)                                    (* \; "(RAND 0) = 0")


            0)
           ((FIXP LOWER)                                     (* \; "(RAND n) = (RAND 0 n-1)")


            (IREMAINDER
 (CAAR RANDSTATE)
                   LOWER))
           (T                                                (* \; 

                                                            "(RAND N) N floating.  Return (RAND 0 N)")


              (FTIMES LOWER (FQUOTIENT (CAAR RANDSTATE)
                                   (CONSTANT (FLOAT (ADD1
 MAX.SMALLP))))))))
       ((AND (FIXP LOWER)
             (FIXP UPPER))
        (OR (IGREATERP
 UPPER LOWER)
            (|swap|
 UPPER LOWER))
        (SETQ UPPER (IDIFFERENCE
 UPPER LOWER))
        (COND
           ((IGREATERP
 UPPER MAX.SMALLP)
            (IPLUS
 (IMOD
 (\\MAKENUMBER
 (CAAR RANDSTATE)
                                (CADAR RANDSTATE))
                         (ADD1
 UPPER))
                   LOWER))
           (T (IPLUS
 (IREMAINDER
 (CAAR RANDSTATE)
                            (ADD1
 UPPER))
                     LOWER))))
       (T (FPLUS (FTIMES (FDIFFERENCE UPPER LOWER)
                        (FQUOTIENT (CAAR RANDSTATE)
                               (CONSTANT (FLOAT (ADD1
 MAX.SMALLP)))))
                 LOWER)))))

(expt

  (lambda (a n)
                                              (* \; "Edited  8-Apr-87 11:41 by jop")

    (cond
       ((fixp n)
        (cond
           ((fixp a)
            (cond
               ((not (igreaterp
 n 0))
                (cond
                   ((eq 0 n)
                    1)
                   (t (fexpt a n))))
               ((eq 0 a)
                0)
               (t 
          
          (* |;;| "Integer EXPonentiation -- works by clever bit-dissection method")


                  (prog ((v 1))
                    lp  (cond
                           ((oddp
 n)
                            (setq v (times
 a v))))
                        (cond
                           ((eq 0 (setq n (rsh
 n 1)))
                            (return v)))
                        (setq a (times
 a a))
                        (go lp)))))
           ((feqp 0.0 (setq a (float a)))
            (cond
               ((eq 0 n)
                1.0)
               (t 0.0)))
           (t 
          
          (* |;;| "Real EXPonentiation -- works by clever bit-dissection method")


              (prog ((v 1.0))
                    (cond
                       ((ilessp
 n 0)
                        (setq a (fquotient 1.0 a))
                        (setq n (iminus
 n))))
                lp  (cond
                       ((oddp
 n)
                        (setq v (times
 a v))))
                    (cond
                       ((eq 0 (setq n (lrsh
 n 1)))
                        (return v)))
                    (setq a (times
 a a))
                    (go lp)))))
       (t (fexpt a n)))))
)
(DECLARE\: DONTEVAL@LOAD DOCOPY 

(RPAQQ RANDSTATE
 NIL)

(RPAQQ \\TOL
 9.9999925E-6)
)
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS RANDSTATE \\TOL)
)
(DEFINEQ

(|PutUnboxed|

  (lambda (ptr num)
                                          (* |JonL| "25-JUL-83 02:29")

    (\\putfixp
 ptr num)))

(\\putfixp

  (lambda (ptr num)
                                          (* |lmm| "11-DEC-80 15:10")

    (prog (hi lo)
          (.unbox. num hi lo)
          (|replace|
 (fixp hinum) |of|
 ptr |with|
 hi)
          (|replace|
 (fixp lonum) |of|
 ptr |with|
 lo)
          (return num))))

(\\putswappedfixp

  (lambda (ptr num)
                                          (* \; "Edited  8-Apr-87 11:41 by jop")

          
          (* |;;| "store in MESA order rather than LISP order")


    (prog (hi lo)
          (.unbox. num hi lo)
          (|replace|
 (fixp lonum) |of|
 ptr |with|
 hi)
          (|replace|
 (fixp hinum) |of|
 ptr |with|
 lo)
          (return num))))

(\\hinum

  (lambda (num)
                                              (* |lmm| "12-APR-81 22:01")

    (prog (hi lo)
          (.unbox. num hi lo)
          (return hi))))

(\\lonum

  (lambda (num)
                                              (* |lmm| "12-APR-81 22:02")

    (prog (hi lo)
          (.unbox. num hi lo)
          (return lo))))
)
(* "FOLLOWING DEFINITIONS EXPORTED")

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

(PUTPROPS |PutUnboxed|
 DMACRO
 (= . \\PUTFIXP))
)
)

(* "END EXPORTED DEFINITIONS")

(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 MIN MAX IMIN IMAX FMIN FMAX TIMES PLUS LOGXOR LOGOR LOGAND ITIMES IPLUS)
)



(* |;;| "ODDP redefined in cmlarith")


(DEFINEQ

(poweroftwop

  (lambda (x)
    (declare
 (localvars . t))
                                (* \; "Edited  8-Apr-87 11:42 by jop")

          
          (* |;;| "Non-NIL iff arg is some power of 2")


    (|if|
 (and (eq (systemtype)
                   'd)
               (not (smallp x)))
        |then|
 (and (fixp x)
                    (igreaterp
 x 0)
                    (|if|
 (eq (logand
 x (constant (sub1
 (expt
 2 16))))
                              0)
                        |then|
 (poweroftwop
 (rsh
 x 16))
                      |else|
 (and (eq (rsh
 x 16)
                                      0)
                                  (.2^np. (logand
 x (sub1
 (expt
 2 16)))))))
      |else|
 (|if|
 (igreaterp
 x 0)
                 |then|
 (.2^np. x)))))

(imod

  (lambda (x n)
                                              (* |lmm| "20-OCT-82 15:07")

    (cond
       ((igeq
 (setq x (iremainder
 x n))
              0)
        x)
       (t (iplus
 n x)))))

(oddp

  (cl:lambda (cl:number &optional (modulus 2))
               (* |lmm| "22-May-86 17:26")

         (not (zerop
 (cl:mod cl:number modulus)))))
)
(DECLARE\: DONTCOPY 
(DECLARE\: EVAL@COMPILE 

(PUTPROPS .2^NP.
 MACRO
 (OPENLAMBDA (X)
                                      (EQ (LOGAND
 X (SUB1
 X))
                                          0)))
)
)



(* \; "MIN and MAX")


(DEFINEQ

(flessp

  (lambda (x y)
    (fgreaterp y x)))

(fmax

  (lambda k
                                                  (* |bvm:| "14-Feb-85 23:48")

    (cond
       ((eq k 0)
        min.float)
       (t (prog ((j 1)
                 (x (float (arg k 1)))
                 y)
                (or (numberp x)
                    (errorx (list 10 x)))
            lp  (cond
                   ((eq j k)
                    (return x)))
                (add1var j)
                (cond
                   ((fgreaterp (setq y (float (arg k j)))
                           x)
                    (setq x y)))
                (go lp))))))

(fmin

  (lambda k
                                                  (* |bvm:| "14-Feb-85 23:49")

    (cond
       ((eq k 0)
        max.float)
       (t (prog ((j 1)
                 (x (float (arg k 1)))
                 y)
                (or (numberp x)
                    (errorx (list 10 x)))
            lp  (cond
                   ((eq j k)
                    (return x)))
                (add1var j)
                (cond
                   ((fgreaterp x (setq y (float (arg k j))))
                    (setq x y)))
                (go lp))))))

(geq

  (lambda (x y)
    (not (lessp
 x y))))

(igeq

  (lambda (x y)
    (not (ilessp
 x y))))

(ileq

  (lambda (x y)
    (not (igreaterp
 x y))))

(imax

  (lambda k
                                                  (* |bvm:| "14-Feb-85 23:49")

    (cond
       ((eq k 0)
        min.integer)
       (t (prog ((j 1)
                 (x (arg k 1)))
            lp  (cond
                   ((eq j k)
                    (return x)))
                (add1var j)
                (cond
                   ((ilessp
 x (arg k j))
                    (setq x (arg k j))))
                (go lp))))))

(imin

  (lambda k
                                                  (* |bvm:| "14-Feb-85 23:49")

    (cond
       ((eq k 0)
        max.integer)
       (t (prog ((j 1)
                 (x (arg k 1)))
            lp  (cond
                   ((eq j k)
                    (return x)))
                (add1var j)
                (cond
                   ((igreaterp
 x (arg k j))
                    (setq x (arg k j))))
                (go lp))))))

(leq

  (lambda (x y)
    (not (greaterp
 x y))))

(max

  (lambda k
                                                  (* |lmm| "12-Apr-85 08:42")

    (cond
       ((eq k 0)
        min.integer)
       (t (prog ((j 1)
                 (x (arg k 1))
                 y)
                (or (numberp x)
                    (errorx (list 10 x)))
            lp  (cond
                   ((eq j k)
                    (return x)))
                (add1var j)
                (cond
                   ((greaterp
 (setq y (arg k j))
                           x)
                    (setq x y)))
                (go lp))))))

(min

  (lambda k
                                                  (* |lmm| "12-Apr-85 08:42")

    (cond
       ((eq k 0)
        max.integer)
       (t (prog ((j 1)
                 (x (arg k 1))
                 y)
                (or (numberp x)
                    (errorx (list 10 x)))
            lp  (cond
                   ((eq j k)
                    (return x)))
                (add1var j)
                (cond
                   ((greaterp
 x (setq y (arg k j)))
                    (setq x y)))
                (go lp))))))
)
(DECLARE\: EVAL@COMPILE 

(ADDTOVAR GLOBALVARS
 MAX.INTEGER MIN.INTEGER MAX.FLOAT MIN.FLOAT)
)
(DECLARE\: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD 
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
)
(PUTPROPS LLARITH COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 
1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (4408 4876 (IDIFFERENCE 4418 . 4570) (IGREATERP 4572 . 4724) (IQUOTIENT 4726 . 4874)) (
4979 19091 (\\SLOWIPLUS2 4989 . 6522) (\\SLOWPLUS2 6524 . 7239) (\\SLOWIDIFFERENCE 7241 . 9497) (
\\SLOWDIFFERENCE 9499 . 10243) (\\SLOWIGREATERP 10245 . 10785) (\\SLOWLLSH1 10787 . 11378) (
\\SLOWLLSH8 11380 . 11814) (\\SLOWLOGAND2 11816 . 12216) (\\SLOWLOGOR2 12218 . 12613) (\\SLOWLOGXOR2 
12615 . 13015) (\\SLOWLRSH1 13017 . 13471) (\\SLOWLRSH8 13473 . 13845) (\\SLOWITIMES2 13847 . 17437) (
\\SLOWTIMES2 17439 . 18177) (\\SLOWIQUOTIENT 18179 . 18353) (\\SLOWQUOTIENT 18355 . 19089)) (19170 
20589 (\\BOXIPLUS 19180 . 19387) (\\BOXIDIFFERENCE 19389 . 20587)) (20620 21196 (\\MAKENUMBER 20630 . 
21194)) (21197 21516 (OVERFLOW 21207 . 21514)) (21871 22749 (\\GETBASEFIXP 21881 . 22159) (
\\PUTBASEFIXP 22161 . 22451) (\\PUTBASEFIXP.UFN 22453 . 22747)) (31874 38017 (EQP 31884 . 32337) (FIX 
32339 . 32532) (IQUOTIENT 32534 . 32682) (IREMAINDER 32684 . 32835) (LLSH 32837 . 33917) (LRSH 33919
 . 35027) (LSH 35029 . 35636) (RSH 35638 . 35901) (\\RSH 35903 . 38015)) (47923 56685 (MINUSP 47933 . 
48304) (ILESSP 48306 . 48359) (IMINUS 48361 . 48414) (IPLUS 48416 . 49159) (ITIMES 49161 . 49911) (
LOGAND 49913 . 50663) (LOGOR 50665 . 51408) (LOGXOR 51410 . 52160) (SUB1 52162 . 52307) (ZEROP 52309
 . 52500) (ADD1 52502 . 52641) (GCD 52643 . 53083) (IEQP 53085 . 53227) (INTEGERLENGTH 53229 . 56683))
 (56887 60328 (ABS 56897 . 57610) (DIFFERENCE 57612 . 57773) (GREATERP 57775 . 58010) (PLUS 58012 . 
58681) (QUOTIENT 58683 . 59074) (REMAINDER 59076 . 59302) (LESSP 59304 . 59536) (MINUS 59538 . 59749) 
(TIMES 59751 . 60326)) (60329 60682 (FMINUS 60339 . 60473) (FREMAINDER 60475 . 60680)) (60683 67332 (
RANDSET 60693 . 62940) (RAND 62942 . 65665) (EXPT 65667 . 67330)) (67494 68755 (|PutUnboxed| 67504 . 
67649) (\\PUTFIXP 67651 . 67968) (\\PUTSWAPPEDFIXP 67970 . 68385) (\\HINUM 68387 . 68569) (\\LONUM 
68571 . 68753)) (69183 70426 (POWEROFTWOP 69193 . 70036) (IMOD 70038 . 70260) (ODDP 70262 . 70424)) (
70671 74183 (FLESSP 70681 . 70730) (FMAX 70732 . 71325) (FMIN 71327 . 71893) (GEQ 71895 . 71947) (IGEQ
 71949 . 72003) (ILEQ 72005 . 72062) (IMAX 72064 . 72523) (IMIN 72525 . 72987) (LEQ 72989 . 73044) (
MAX 73046 . 73626) (MIN 73628 . 74181)))))
STOP