(FILECREATED "11-Sep-86 16:42:40" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;39 123984
changes to: (STRUCTURES RATIO COMPLEX)
(VARS CMLARITHCOMS)
(MACROS .CMLUNBOX. .CMLIQUOTREM.)
(FNS ISQRT PRIMEP PHASE SIGNUM %%SIGNUM 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- COMPLEX REALPART IMAGPART
%%COMPLEX+ %%COMPLEX- %%COMPLEX* %%COMPLEX/ %%COMPLEX-ABS %%COMPLEX-MINUS
%%COMPLEX-TIMESI CONJUGATE %%COMPLEX-PRINT NEW-MINUSP CL:ZEROP EVENP ODDP
PLUSP %%= %%> = /= < > <= >= + - CL:* / %%/ 1+ 1- CL:GCD %%GCD LCM FLOAT
\FLOAT CL:FLOOR TRUNCATE CEILING ROUND CL:MOD REM FFLOOR FCEILING FTRUNCATE
FROUND DECODE-FLOAT SCALE-FLOAT FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS
FLOAT-PRECISION INTEGER-DECODE-FLOAT NEW-LESSP NEW-EQP NEW-ABS NEW-MINUS
NEW-SLOWIPLUS2 NEW-SLOWIDIFFERENCE NEW-SLOWITIMES2 NEW-SLOWIQUOTIENT
NEW-IREMAINDER NEW-SLOWIGREATERP %%+ %%- %%* LOGIOR LOGEQV LOGNAND LOGNOR
LOGANDC1 LOGANDC2 LOGORC1 LOGORC2 BOOLE LOGTEST LOGBITP ASH LOGCOUNT
%%LOGCOUNT INTEGER-LENGTH BYTE-SIZE BYTE-POSITION LDB-TEST MASK-FIELD
DEPOSIT-FIELD)
previous date: "20-Aug-86 20:33:58" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;38)
(* 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) (* Returns second result of TRUNCATE.
*)
(MULTIPLE-VALUE-BIND (TRU REM)
(TRUNCATE NUMBER DIVISOR)
(CL:DECLARE (IGNORE TRU))
REM)))
(FFLOOR
(CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1)) (* Same as CL:FLOOR, but returns first
value as a float. *)
(MULTIPLE-VALUE-BIND (FLR REM)
(CL:FLOOR NUMBER DIVISOR)
(VALUES (FLOAT FLR)
REM))))
(FCEILING
(CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1)) (* Same as CEILING, but returns first
value as a float. *)
(MULTIPLE-VALUE-BIND (CEI REM)
(CEILING NUMBER DIVISOR)
(VALUES (FLOAT CEI)
REM))))
(FTRUNCATE
(CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1)) (* Same as TRUNCATE, but returns first
value as a float. *)
(MULTIPLE-VALUE-BIND (TRU REM)
(TRUNCATE NUMBER DIVISOR)
(VALUES (FLOAT TRU)
REM))))
(FROUND
(CL:LAMBDA (NUMBER &OPTIONAL (DIVISOR 1)) (* Same as ROUND, but returns first
value as a float. *)
(MULTIPLE-VALUE-BIND (ROU REM)
(ROUND NUMBER DIVISOR)
(VALUES (FLOAT ROU)
REM))))
)
(* Page 218 functions. *)
(DEFINEQ
(DECODE-FLOAT
(CL:LAMBDA (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: "12-Jul-86 18:29")
(CL: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 (13799 17894 (ISQRT 13809 . 15235) (PRIMEP 15237 . 16137) (PHASE 16139 . 16708) (SIGNUM
16710 . 17575) (%%SIGNUM 17577 . 17892)) (18277 33825 (NUMERATOR 18287 . 18675) (DENOMINATOR 18677 .
19066) (RATIONALP 19068 . 19231) (RATIONAL 19233 . 20666) (RATIONALIZE 20668 . 21566) (%%RATIO-PRINT
21568 . 23154) (%%BUILD-RATIO 23156 . 24236) (%%RATIONALIZE-FLOAT 24238 . 28264) (%%RATIO* 28266 .
28902) (%%RATIO/ 28904 . 29409) (%%RATIO-TIMES-QUOTIENT 29411 . 30113) (%%RATIO+ 30115 . 30540) (
%%RATIO- 30542 . 30621) (%%RATIO-PLUS-DIFFERENCE 30623 . 31849) (%%RATIO-INTEGER* 31851 . 32791) (
%%RATIO-INTEGER+ 32793 . 33271) (%%RATIO-INTEGER- 33273 . 33823)) (34253 39010 (COMPLEX 34263 . 35340)
(REALPART 35342 . 35552) (IMAGPART 35554 . 35791) (%%COMPLEX+ 35793 . 36053) (%%COMPLEX- 36055 .
36318) (%%COMPLEX* 36320 . 36768) (%%COMPLEX/ 36770 . 37512) (%%COMPLEX-ABS 37514 . 37799) (
%%COMPLEX-MINUS 37801 . 38008) (%%COMPLEX-TIMESI 38010 . 38400) (CONJUGATE 38402 . 38692) (
%%COMPLEX-PRINT 38694 . 39008)) (39142 39290 (NEW-MINUSP 39152 . 39288)) (39372 39521 (CL:ZEROP 39382
. 39519)) (39522 39980 (EVENP 39532 . 39684) (ODDP 39686 . 39843) (PLUSP 39845 . 39978)) (40032 43931
(%%= 40042 . 42499) (%%> 42501 . 43929)) (43932 48491 (= 43942 . 44117) (%%= 44119 . 46576) (/= 46578
. 46858) (< 46860 . 47267) (> 47269 . 47653) (<= 47655 . 48057) (>= 48059 . 48489)) (55348 60152 (+
55358 . 55984) (- 55986 . 56487) (CL:* 56489 . 56923) (/ 56925 . 57217) (%%/ 57219 . 59894) (1+ 59896
. 60022) (1- 60024 . 60150)) (62580 66969 (CL:GCD 62590 . 64000) (%%GCD 64002 . 65502) (LCM 65504 .
66967)) (67146 69171 (FLOAT 67156 . 67396) (\FLOAT 67398 . 69169)) (69249 77729 (CL:FLOOR 69259 .
70427) (TRUNCATE 70429 . 72640) (CEILING 72642 . 73735) (ROUND 73737 . 75452) (CL:MOD 75454 . 75954) (
REM 75956 . 76286) (FFLOOR 76288 . 76647) (FCEILING 76649 . 77008) (FTRUNCATE 77010 . 77372) (FROUND
77374 . 77727)) (77764 81162 (DECODE-FLOAT 77774 . 78680) (SCALE-FLOAT 78682 . 79498) (FLOAT-RADIX
79500 . 79666) (FLOAT-SIGN 79668 . 79919) (FLOAT-DIGITS 79921 . 80149) (FLOAT-PRECISION 80151 . 80363)
(INTEGER-DECODE-FLOAT 80365 . 81160)) (81719 82976 (NEW-LESSP 81729 . 81859) (NEW-EQP 81861 . 82106)
(NEW-ABS 82108 . 82842) (NEW-MINUS 82844 . 82974)) (94251 102501 (NEW-SLOWIPLUS2 94261 . 95807) (
NEW-SLOWIDIFFERENCE 95809 . 98122) (NEW-SLOWITIMES2 98124 . 101619) (NEW-SLOWIQUOTIENT 101621 . 101805
) (NEW-IREMAINDER 101807 . 101960) (NEW-SLOWIGREATERP 101962 . 102499)) (103550 111793 (%%+ 103560 .
105401) (%%- 105403 . 107342) (%%* 107344 . 109114) (%%/ 109116 . 111791)) (112251 114538 (LOGIOR
112261 . 113191) (LOGEQV 113193 . 113564) (LOGNAND 113566 . 113721) (LOGNOR 113723 . 113876) (LOGANDC1
113878 . 114050) (LOGANDC2 114052 . 114208) (LOGORC1 114210 . 114380) (LOGORC2 114382 . 114536)) (
114585 115429 (BOOLE 114595 . 115427)) (115891 116248 (LOGTEST 115901 . 116078) (LOGBITP 116080 .
116246)) (116249 116722 (ASH 116259 . 116720)) (116723 119106 (LOGCOUNT 116733 . 118201) (%%LOGCOUNT
118203 . 119104)) (119107 121180 (INTEGER-LENGTH 119117 . 121178)) (121304 121673 (BYTE-SIZE 121314 .
121488) (BYTE-POSITION 121490 . 121671)) (121739 122238 (LDB-TEST 121749 . 121934) (MASK-FIELD 121936
. 122236)) (122304 122721 (DEPOSIT-FIELD 122314 . 122719)))))
STOP