(FILECREATED "28-Jul-86 18:08:25" {ERIS}<ROACH>CML>CMLARITH.;12 117423
changes to: (VARS CMLARITHCOMS)
(MACROS .CMLUNBOX. .CMLIQUOTREM.)
(FNS NEW-SLOWIQUOTIENT NEW-IREMAINDER NEW-SLOWIPLUS2 NEW-SLOWIDIFFERENCE
NEW-SLOWITIMES2 NEW-SLOWIGREATERP)
previous date: "23-Jul-86 16:28:40" {ERIS}<ROACH>CML>CMLARITH.;10)
(* 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 %%BUILD-RATIO RATIONALP RATIONAL RATIONALIZE
%%RATIONALIZE-FLOAT %%RATIO* %%RATIO/ %%RATIO-TIMES-QUOTIENT %%RATIO+ %%RATIO-
%%RATIO-PLUS-DIFFERENCE %%RATIO-INTEGER* %%RATIO-INTEGER+ %%RATIO-INTEGER-))
(COMS (* Section 2.1.4 Complex Numbers. *)
(STRUCTURES COMPLEX)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (* Make it so that COMPLEX is NUMBERP *)
(\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE COMPLEX))
(LOGOR \TT.NUMBERP \TT.ATOM))))
(* TBW: Reading complex numbers. *)
(FNS COMPLEX REALPART IMAGPART %%COMPLEX+ %%COMPLEX- %%COMPLEX* %%COMPLEX/
%%COMPLEX-ABS %%COMPLEX-MINUS %%COMPLEX-TIMESI CONJUGATE \PRINT.COMPLEX))
(COMS (* Section 12.2 Predicates on Numbers. *)
(* MINUSP is 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 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 \PRINT.COMPLEX %%COMPLEX-TIMESI
%%COMPLEX-MINUS %%COMPLEX-ABS %%COMPLEX/ %%COMPLEX* %%COMPLEX- %%COMPLEX+
IMAGPART REALPART COMPLEX %%RATIO-INTEGER- %%RATIO-INTEGER+
%%RATIO-INTEGER* %%RATIO-PLUS-DIFFERENCE %%RATIO- %%RATIO+
%%RATIO-TIMES-QUOTIENT %%RATIO/ %%RATIO* %%RATIONALIZE-FLOAT RATIONALIZE
RATIONAL %%BUILD-RATIO DENOMINATOR NUMERATOR %%SIGNUM SIGNUM PHASE PRIMEP
ISQRT)))))
(* * CMLARITH. Common Lisp Arithmetic. Covers all of Common Lisp arithmetic except for higher
math functions. Covers sections 2.1-2.1.4, 12.1-12.4, and 12.6-12.10 Doesn't cover sections
12.5-12.5.3. -- 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))) (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)))))
(%%BUILD-RATIO
(CL:LAMBDA (X Y) (* kbr: " 8-May-86 22:13")
(* %%BUILD-RATIO takes two integer
arguments and builds the rational
number which is their quotient.
*)
(MULTIPLE-VALUE-BIND (Q R)
(TRUNCATE X Y)
(CL:IF (ZEROP R)
Q
(LET ((CL:GCD (%%GCD X Y)))
(CL:UNLESS (= CL:GCD 1)
(PROGN (SETQ X (/ X CL:GCD))
(SETQ Y (/ Y CL:GCD))))
(CL:IF (MINUSP Y)
(%%MAKE-RATIO (- X)
(- Y))
(%%MAKE-RATIO X Y)))))))
(RATIONALP
(LAMBDA (NUMBER) (* lmm "22-May-86 15:45")
(OR (INTEGERP NUMBER)
(RATIO-P NUMBER))))
(RATIONAL
(CL:LAMBDA (NUMBER) (* lmm "19-Jun-86 14:42")
(* Rational produces a rational number
for any numeric argument.
Rational assumed that the floating
point is completely accurate.
*)
(ETYPECASE NUMBER (INTEGER NUMBER)
(FLOAT (MULTIPLE-VALUE-BIND (F E SIGN)
(DECODE-FLOAT NUMBER)
(LET* ((PRECISION (FLOAT-PRECISION F))
(F (TRUNCATE (SCALE-FLOAT F PRECISION)))
(V (CL:IF (MINUSP E)
(%%BUILD-RATIO F (ASH 1 (- PRECISION E)))
(%%BUILD-RATIO (ASH F E)
(ASH 1 PRECISION)))))
V)))
(RATIO NUMBER)
(COMPLEX (%%MAKE-COMPLEX (RATIONAL (REALPART NUMBER))
(RATIONAL (IMAGPART NUMBER)))))))
(RATIONALIZE
(CL:LAMBDA (NUMBER) (* kbr: "12-Jul-86 18:05")
(* 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 SINGLE-FLOAT-EPSILON))
(COMPLEX (%%MAKE-COMPLEX (RATIONALIZE (REALPART NUMBER))
(RATIONALIZE (IMAGPART NUMBER)))))))
(%%RATIONALIZE-FLOAT
(CL:LAMBDA (X &OPTIONAL (EPS LONG-FLOAT-EPSILON)) (* kbr: " 8-May-86 17:35")
(* Produce a rational approximating X.
*)
(COND
((MINUSP X)
(- (RATIONALIZE (- X))))
((ZEROP X)
0)
(T (LET ((Y NIL)
(A NIL))
(CL:DO ((XX X (SETQ Y (/ 1.0 (- XX (FLOAT A X)))))
(NUM (SETQ A (TRUNCATE X))
(+ (CL:* (SETQ A (TRUNCATE Y))
NUM)
ONUM))
(DEN 1 (+ (CL:* A DEN)
ODEN))
(ONUM 1 NUM)
(ODEN 0 DEN))
((AND (NOT (ZEROP DEN))
(NOT (> (ABS (/ (- X (/ (FLOAT NUM X)
(FLOAT DEN X)))
X))
EPS)))
(/ NUM DEN))))))))
(%%RATIO*
(CL:LAMBDA (X Y) (* kbr: " 8-Apr-86 16:10")
(* %%RATIO* does a ratio to ratio
multiplication. %%RATIO/ does a ratio
to ratio division. *)
(LET* ((NUMX (NUMERATOR X))
(NUMY (NUMERATOR Y))
(DENX (DENOMINATOR X))
(DENY (DENOMINATOR Y)))
(%%RATIO-TIMES-QUOTIENT NUMX DENX NUMY DENY))))
(%%RATIO/
(CL:LAMBDA (X Y) (* kbr: " 8-Apr-86 14:02")
(LET* ((NUMX (NUMERATOR X))
(NUMY (NUMERATOR Y))
(DENX (DENOMINATOR X))
(DENY (DENOMINATOR Y)))
(CL:IF (MINUSP NUMY)
(%%RATIO-TIMES-QUOTIENT NUMX DENX (- DENY)
(- NUMY))
(%%RATIO-TIMES-QUOTIENT NUMX DENX DENY NUMY)))))
(%%RATIO-TIMES-QUOTIENT
(CL:LAMBDA (H1 K1 H2 K2) (* kbr: " 8-Apr-86 16:40")
(LET ((GCDH1K2 (%%GCD H1 K2))
(GCDH2K1 (%%GCD H2 K1)))
(CL:UNLESS (= GCDH1K2 1)
(PROGN (SETQ H1 (/ H1 GCDH1K2))
(SETQ K2 (/ K2 GCDH1K2))))
(CL:UNLESS (= GCDH2K1 1)
(PROGN (SETQ H2 (/ H2 GCDH2K1))
(SETQ K1 (/ K1 GCDH2K1)))))
(LET ((H (CL:* H1 H2))
(K (CL:* K1 K2)))
(CL:IF (= K 1)
H
(%%MAKE-RATIO H K)))))
(%%RATIO+
(CL:LAMBDA (X Y) (* %%sp-ratio+ does a ratio to ratio
addition. %%sp-ratio-
does a ratio to ratio subtraction.
VM:T *)
(%%RATIO-PLUS-DIFFERENCE X Y NIL)))
(%%RATIO-
(CL:LAMBDA (X Y)
(%%RATIO-PLUS-DIFFERENCE X Y T)))
(%%RATIO-PLUS-DIFFERENCE
(CL:LAMBDA (X Y DIFFERENCEFLG) (* kbr: " 8-May-86 21:08")
(LET* ((H1 (NUMERATOR X))
(K1 (DENOMINATOR X))
(H2 (NUMERATOR Y))
(K2 (DENOMINATOR Y))
(D1 (%%GCD K1 K2)))
(CL:WHEN DIFFERENCEFLG (SETQ H2 (- H2)))
(CL:IF (= D1 1)
(%%MAKE-RATIO (+ (CL:* H1 K2)
(CL:* H2 K1))
(CL:* K1 K2))
(LET* ((K1/D1 (/ K1 D1))
(TEE (+ (CL:* H1 (/ K2 D1))
(CL:* H2 K1/D1)))
(D2 (%%GCD TEE D1))
(K2/D2 K2))
(CL:UNLESS (= D2 1)
(PROGN (SETQ K2/D2 (/ K2 D2))
(SETQ TEE (/ TEE D2))))
(CL:IF (= K1/D1 1 K2/D2)
TEE
(%%MAKE-RATIO TEE (CL:* K1/D1 K2/D2))))))))
(%%RATIO-INTEGER*
(CL:LAMBDA (X Y) (* kbr: " 8-Apr-86 20:19")
(* %%RATIO-INTEGER* multiplies a ratio
by an integer. *)
(CL:IF (ZEROP Y)
0
(LET* ((DEN (DENOMINATOR X))
(CL:GCD (%%GCD DEN Y)))
(CL:UNLESS (= CL:GCD 1)
(PROGN (SETQ Y (/ Y CL:GCD))
(SETQ DEN (/ DEN CL:GCD))))
(CL:IF (= DEN 1)
(CL:* (NUMERATOR X)
Y)
(%%MAKE-RATIO (CL:* (NUMERATOR X)
Y)
DEN))))))
(%%RATIO-INTEGER+
(CL:LAMBDA (X Y) (* lmm "22-May-86 15:41")
(* %%RATIO-INTEGER+ adds an integer to
a ratio. *)
(LET ((DENX (RATIO-DENOMINATOR X)))
(%%MAKE-RATIO (+ (RATIO-NUMERATOR X)
(CL:* DENX Y))
DENX))))
(%%RATIO-INTEGER-
(CL:LAMBDA (X Y) (* lmm "22-May-86 15:41")
(* %%RATIO-INTEGER- subtracts an
integer from a ratio.
*)
(LET ((DENX (RATIO-DENOMINATOR X)))
(%%MAKE-RATIO (- (RATIO-NUMERATOR X)
(CL:* DENX Y))
DENX))))
)
(* Section 2.1.4 Complex Numbers. *)
(DEFSTRUCT (COMPLEX (:PREDICATE COMPLEXP)
(:CONSTRUCTOR %%MAKE-COMPLEX (REALPART IMAGPART))
(:PRINT-FUNCTION \PRINT.COMPLEX)) (REALPART :READ-ONLY) (IMAGPART :READ-ONLY))
(DECLARE: DONTEVAL@LOAD DOCOPY
(* Make it so that COMPLEX is NUMBERP *)
(\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE COMPLEX))
(LOGOR \TT.NUMBERP \TT.ATOM))
)
(* TBW: Reading complex numbers. *)
(DEFINEQ
(COMPLEX
(CL:LAMBDA (REALPART &OPTIONAL (IMAGPART 0)) (* 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))))
(\PRINT.COMPLEX
(CL:LAMBDA (COMPLEX STREAM) (* lmm "26-Jun-86 10:31")
(FORMAT STREAM "~CC(~S ~S)" (INT-CHAR (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
(COMPLEX-REALPART COMPLEX)
(COMPLEX-IMAGPART COMPLEX))))
)
(* Section 12.2 Predicates on Numbers. *)
(* MINUSP is 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) (* lmm "19-Jun-86 15:43")
(\CALLME (QUOTE /)) (* UFN for / Microcode generally
handles the case of two args both
FIXPs)
(CTYPECASE N1 (INTEGER (CTYPECASE N2 (INTEGER (COND
((EVENP N1 N2)
(IQUOTIENT N1 N2))
(T (%%BUILD-RATIO N1 N2))))
(FLOAT (FQUOTIENT N1 N2))
(RATIO (%%/ (CL:* (DENOMINATOR N2)
N1)
(NUMERATOR N2)))
(COMPLEX (%%COMPLEX/ (%%MAKE-COMPLEX N1 0)
N2))))
(FLOAT (CTYPECASE N2 ((OR INTEGER FLOAT)
(FQUOTIENT N1 N2))
(RATIO (%%/ (CL:* (DENOMINATOR N2)
N1)
(NUMERATOR N2)))
(COMPLEX (%%COMPLEX/ (%%MAKE-COMPLEX N1 0.0)
N2))))
(RATIO (CTYPECASE N2 (INTEGER (%%BUILD-RATIO (NUMERATOR N1)
(CL:* (DENOMINATOR N1)
N2)))
(FLOAT (FQUOTIENT N1 N2))
(RATIO (%%RATIO/ N1 N2))
(COMPLEX (%%COMPLEX/ (%%MAKE-COMPLEX N1 0)
N2))))
(COMPLEX (CTYPECASE N2 (INTEGER (%%COMPLEX/ N1 (%%MAKE-COMPLEX N2 0)))
(FLOAT (%%COMPLEX/ N1 (%%MAKE-COMPLEX N2 0.0)))
(RATIO (%%/ (CL:* (DENOMINATOR N2)
N1)
(NUMERATOR N2)))
(COMPLEX (%%COMPLEX/ N1 N2)))))))
(1+
(LAMBDA (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: "21-Jul-86 17:54")
(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: " 9-May-86 00:15")
(* \MAKEFLOAT knows how to handle
underflow and overflow possibilities.
*)
(SETQ FLOAT (\DTEST FLOAT (QUOTE FLOATP)))
(\MAKEFLOAT (fetch (FLOATP SIGNBIT) of FLOAT)
(IPLUS (fetch (FLOATP EXPONENT) of FLOAT)
INTEGER 8)
(IPLUS \HIDDENBIT (fetch (FLOATP HIFRACTION) of FLOAT))
(fetch (FLOATP LOFRACTION) of FLOAT)
T)))
(FLOAT-RADIX
(CL:LAMBDA (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: "12-Jul-86 18:32")
(TYPECASE FLOAT (FLOAT 23)
(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: "12-Jul-86 18:29")
(LET ((PRECISION (FLOAT-PRECISION FLOAT)))
(MULTIPLE-VALUE-BIND (F E S)
(DECODE-FLOAT FLOAT)
(VALUES (TRUNCATE (SCALE-FLOAT F PRECISION))
(- E PRECISION)
S)))))
)
(* 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) (* kbr: "30-Apr-86 16:59")
(COND
((EQ X Y))
((AND (NUMBERP X)
(NUMBERP Y))
(%%= X Y))
((EQ (NTYPX X)
(NTYPX Y))
(SELECTC (NTYPX X)
(\STACKP (EQ (fetch (STACKP EDFXP) of X)
(fetch (STACKP EDFXP) of Y)))
(\ARRAYP (AND (EQ (fetch (ARRAYP TYP) of X)
\ST.CODE)
(EQDEFP X Y)))
NIL))
(T NIL))))
(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) (* lmm " 2-Jul-84 17:12")
(\CALLME (QUOTE IQUOTIENT))
(\IQUOTREM X Y X)
X))
(NEW-IREMAINDER
(LAMBDA (X Y) (* edited: "29-APR-82 05:01")
(\IQUOTREM 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) (* lmm "19-Jun-86 15:43")
(\CALLME (QUOTE /)) (* UFN for / Microcode generally
handles the case of two args both
FIXPs)
(CTYPECASE N1 (INTEGER (CTYPECASE N2 (INTEGER (COND
((EVENP N1 N2)
(IQUOTIENT N1 N2))
(T (%%BUILD-RATIO N1 N2))))
(FLOAT (FQUOTIENT N1 N2))
(RATIO (%%/ (CL:* (DENOMINATOR N2)
N1)
(NUMERATOR N2)))
(COMPLEX (%%COMPLEX/ (%%MAKE-COMPLEX N1 0)
N2))))
(FLOAT (CTYPECASE N2 ((OR INTEGER FLOAT)
(FQUOTIENT N1 N2))
(RATIO (%%/ (CL:* (DENOMINATOR N2)
N1)
(NUMERATOR N2)))
(COMPLEX (%%COMPLEX/ (%%MAKE-COMPLEX N1 0.0)
N2))))
(RATIO (CTYPECASE N2 (INTEGER (%%BUILD-RATIO (NUMERATOR N1)
(CL:* (DENOMINATOR N1)
N2)))
(FLOAT (FQUOTIENT N1 N2))
(RATIO (%%RATIO/ N1 N2))
(COMPLEX (%%COMPLEX/ (%%MAKE-COMPLEX N1 0)
N2))))
(COMPLEX (CTYPECASE N2 (INTEGER (%%COMPLEX/ N1 (%%MAKE-COMPLEX N2 0)))
(FLOAT (%%COMPLEX/ N1 (%%MAKE-COMPLEX N2 0.0)))
(RATIO (%%/ (CL:* (DENOMINATOR N2)
N1)
(NUMERATOR N2)))
(COMPLEX (%%COMPLEX/ N1 N2)))))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\SETUFNENTRY (CAR (\FINDOP (QUOTE PLUS2)))
(QUOTE %%+)
2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE DIFFERENCE)))
(QUOTE %%-)
2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE TIMES2)))
(QUOTE %%*)
2 0)
(\SETUFNENTRY (CAR (\FINDOP (QUOTE GREATERP)))
(QUOTE %%>)
2 0)
)
(* Section 12.7 Logical Operations on Numbers. *)
(* Page 221 functions. LOGAND LOGXOR are OK. *)
(DEFINEQ
(LOGIOR
[LAMBDA N (* lmm "19-Jun-86 16:22")
(* called only by interpreted code -
this defn relies on fact that compiler
turns LOGOR calls into sequences of
opcodes)
(SELECTQ N
(2 (LOGOR (ARG N 1)
(ARG N 2)))
(1 (LOGOR (ARG N 1)))
(0 (LOGOR))
(PROG ((R (LOGOR (ARG N 1)
(ARG N 2)
(ARG N 3)))
(J 4))
LP (COND
((ILEQ J N)
(SETQ R (LOGOR R (ARG N J)))
(SETQ J (ADD1 J))
(GO LP)))
(RETURN R])
(LOGEQV
(CL:LAMBDA (&REST INTEGERS) (* lmm " 5-Sep-85 02:19")
(COND
(INTEGERS (CL:DO* ((RESULT (pop INTEGERS)
(LOGNOT (LOGXOR RESULT (pop INTEGERS)))))
((NULL INTEGERS)
RESULT)))
(T -1))))
(LOGNAND
(CL:LAMBDA (INTEGER1 INTEGER2) (* kbr: "31-Aug-85 21:00")
(LOGNOT (LOGAND INTEGER1 INTEGER2))))
(LOGNOR
(CL:LAMBDA (INTEGER1 INTEGER2) (* kbr: "31-Aug-85 21:00")
(LOGNOT (LOGOR INTEGER1 INTEGER2))))
(LOGANDC1
(CL:LAMBDA (INTEGER1 INTEGER2) (* kbr: "31-Aug-85 21:00")
(LOGAND (LOGNOT INTEGER1)
INTEGER2)))
(LOGANDC2
(CL:LAMBDA (INTEGER1 INTEGER2) (* kbr: "31-Aug-85 21:01")
(LOGAND INTEGER1 (LOGNOT INTEGER2))))
(LOGORC1
(CL:LAMBDA (INTEGER1 INTEGER2) (* kbr: "31-Aug-85 21:01")
(LOGOR (LOGNOT INTEGER1)
INTEGER2)))
(LOGORC2
(CL:LAMBDA (INTEGER1 INTEGER2) (* kbr: "31-Aug-85 21:01")
(LOGOR INTEGER1 (LOGNOT INTEGER2))))
)
(* Page 222.0 BOOLE and constants. *)
(DEFINEQ
(BOOLE
(CL:LAMBDA (OP INTEGER1 INTEGER2) (* lmm " 5-Sep-85 02:24")
(SELECTQ OP
(0 0)
(1 -1)
(2 INTEGER1)
(3 INTEGER2)
(4 (LOGNOT INTEGER1))
(5 (LOGNOT INTEGER2))
(6 (LOGAND INTEGER1 INTEGER2))
(7 (LOGIOR INTEGER1 INTEGER2))
(8 (LOGXOR INTEGER1 INTEGER2))
(9 (LOGEQV INTEGER1 INTEGER2))
(10 (LOGNAND INTEGER1 INTEGER2))
(11 (LOGNOR INTEGER1 INTEGER2))
(12 (LOGANDC1 INTEGER1 INTEGER2))
(13 (LOGANDC2 INTEGER1 INTEGER2))
(14 (LOGORC1 INTEGER1 INTEGER2))
(15 (LOGORC2 INTEGER1 INTEGER2))
(CL:ERROR "~S is not of type (mod 16)." OP))))
)
(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: "31-Aug-85 21:23")
(DEPOSITBYTE NEWBYTE (fetch (BYTESPEC BYTESPEC.POSITION) of BYTESPEC)
(fetch (BYTESPEC BYTESPEC.SIZE) of BYTESPEC)
INTEGER)))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
LLFLOAT LLBIGNUM)
)
(PUTPROPS CMLARITH FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA
DEPOSIT-FIELD MASK-FIELD LDB-TEST BYTE-POSITION BYTE-SIZE LOGCOUNT LOGBITP LOGTEST BOOLE
LOGORC2 LOGORC1 LOGANDC2 LOGANDC1 LOGNOR LOGNAND LOGEQV LOGIOR INTEGER-DECODE-FLOAT
FLOAT-PRECISION FLOAT-DIGITS FLOAT-SIGN FLOAT-RADIX DECODE-FLOAT FROUND FTRUNCATE
FCEILING FFLOOR REM CL:MOD ROUND CEILING TRUNCATE CL:FLOOR FLOAT LCM %%GCD CL:GCD /
CL:* - + >= <= > < /= = PLUSP ODDP EVENP CL:ZEROP \PRINT.COMPLEX %%COMPLEX-TIMESI
%%COMPLEX-MINUS %%COMPLEX-ABS %%COMPLEX/ %%COMPLEX* %%COMPLEX- %%COMPLEX+ IMAGPART
REALPART COMPLEX %%RATIO-INTEGER- %%RATIO-INTEGER+ %%RATIO-INTEGER*
%%RATIO-PLUS-DIFFERENCE %%RATIO- %%RATIO+ %%RATIO-TIMES-QUOTIENT %%RATIO/ %%RATIO*
%%RATIONALIZE-FLOAT RATIONALIZE RATIONAL %%BUILD-RATIO DENOMINATOR NUMERATOR %%SIGNUM
SIGNUM PHASE PRIMEP ISQRT)
)
(PUTPROPS CMLARITH COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (12560 16659 (ISQRT 12570 . 14000) (PRIMEP 14002 . 14902) (PHASE 14904 . 15473) (SIGNUM
15475 . 16340) (%%SIGNUM 16342 . 16657)) (16994 28338 (NUMERATOR 17004 . 17392) (DENOMINATOR 17394 .
17783) (%%BUILD-RATIO 17785 . 18877) (RATIONALP 18879 . 19042) (RATIONAL 19044 . 20477) (RATIONALIZE
20479 . 21398) (%%RATIONALIZE-FLOAT 21400 . 22737) (%%RATIO* 22739 . 23375) (%%RATIO/ 23377 . 23882) (
%%RATIO-TIMES-QUOTIENT 23884 . 24598) (%%RATIO+ 24600 . 25025) (%%RATIO- 25027 . 25106) (
%%RATIO-PLUS-DIFFERENCE 25108 . 26342) (%%RATIO-INTEGER* 26344 . 27288) (%%RATIO-INTEGER+ 27290 .
27776) (%%RATIO-INTEGER- 27778 . 28336)) (28808 33564 (COMPLEX 28818 . 29891) (REALPART 29893 . 30103)
(IMAGPART 30105 . 30338) (%%COMPLEX+ 30340 . 30600) (%%COMPLEX- 30602 . 30865) (%%COMPLEX* 30867 .
31315) (%%COMPLEX/ 31317 . 32059) (%%COMPLEX-ABS 32061 . 32350) (%%COMPLEX-MINUS 32352 . 32559) (
%%COMPLEX-TIMESI 32561 . 32951) (CONJUGATE 32953 . 33247) (\PRINT.COMPLEX 33249 . 33562)) (33696 33844
(NEW-MINUSP 33706 . 33842)) (33926 34075 (CL:ZEROP 33936 . 34073)) (34076 34531 (EVENP 34086 . 34238)
(ODDP 34240 . 34394) (PLUSP 34396 . 34529)) (34583 38435 (%%= 34593 . 37030) (%%> 37032 . 38433)) (
38436 42975 (= 38446 . 38621) (%%= 38623 . 41060) (/= 41062 . 41342) (< 41344 . 41751) (> 41753 .
42137) (<= 42139 . 42541) (>= 42543 . 42973)) (49832 54322 (+ 49842 . 50468) (- 50470 . 50971) (CL:*
50973 . 51407) (/ 51409 . 51701) (%%/ 51703 . 54064) (1+ 54066 . 54192) (1- 54194 . 54320)) (56749
61142 (CL:GCD 56759 . 58169) (%%GCD 58171 . 59675) (LCM 59677 . 61140)) (61319 63348 (FLOAT 61329 .
61569) (\FLOAT 61571 . 63346)) (63425 71901 (CL:FLOOR 63435 . 64603) (TRUNCATE 64605 . 66816) (CEILING
66818 . 67911) (ROUND 67913 . 69636) (CL:MOD 69638 . 70142) (REM 70144 . 70474) (FFLOOR 70476 . 70831
) (FCEILING 70833 . 71188) (FTRUNCATE 71190 . 71548) (FROUND 71550 . 71899)) (71936 74670 (
DECODE-FLOAT 71946 . 72647) (SCALE-FLOAT 72649 . 73374) (FLOAT-RADIX 73376 . 73542) (FLOAT-SIGN 73544
. 73791) (FLOAT-DIGITS 73793 . 74021) (FLOAT-PRECISION 74023 . 74235) (INTEGER-DECODE-FLOAT 74237 .
74668)) (75227 76830 (NEW-LESSP 75237 . 75367) (NEW-EQP 75369 . 75956) (NEW-ABS 75958 . 76696) (
NEW-MINUS 76698 . 76828)) (88105 96349 (NEW-SLOWIPLUS2 88115 . 89661) (NEW-SLOWIDIFFERENCE 89663 .
91976) (NEW-SLOWITIMES2 91978 . 95473) (NEW-SLOWIQUOTIENT 95475 . 95654) (NEW-IREMAINDER 95656 . 95808
) (NEW-SLOWIGREATERP 95810 . 96347)) (97398 105331 (%%+ 97408 . 99249) (%%- 99251 . 101190) (%%*
101192 . 102966) (%%/ 102968 . 105329)) (105789 108073 (LOGIOR 105799 . 106726) (LOGEQV 106728 .
107099) (LOGNAND 107101 . 107256) (LOGNOR 107258 . 107411) (LOGANDC1 107413 . 107585) (LOGANDC2 107587
. 107743) (LOGORC1 107745 . 107915) (LOGORC2 107917 . 108071)) (108120 108964 (BOOLE 108130 . 108962)
) (109426 109783 (LOGTEST 109436 . 109613) (LOGBITP 109615 . 109781)) (109784 110257 (ASH 109794 .
110255)) (110258 112641 (LOGCOUNT 110268 . 111736) (%%LOGCOUNT 111738 . 112639)) (112642 114715 (
INTEGER-LENGTH 112652 . 114713)) (114839 115208 (BYTE-SIZE 114849 . 115023) (BYTE-POSITION 115025 .
115206)) (115274 115773 (LDB-TEST 115284 . 115469) (MASK-FIELD 115471 . 115771)) (115839 116148 (
DEPOSIT-FIELD 115849 . 116146)))))
STOP