(FILECREATED " 5-Aug-86 15:47:15" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;27 117441
changes to: (FNS NEW-SLOWIQUOTIENT NEW-IREMAINDER %%RATIO-PRINT %%COMPLEX-PRINT)
(STRUCTURES RATIO COMPLEX)
(VARS CMLARITHCOMS)
previous date: "28-Jul-86 18:08:25" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;25)
(* 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))))
(* TBW: Reading complex numbers. *)
(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 LLBIGNUM))
(PROP FILETYPE CMLARITH)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA LOGEQV LOGIOR FLOAT-SIGN FROUND FTRUNCATE FCEILING FFLOOR ROUND CEILING
TRUNCATE CL:FLOOR LCM CL:GCD CL:* + /= ODDP EVENP %%COMPLEX-PRINT COMPLEX
%%RATIONALIZE-FLOAT)))))
(* * 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: "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)))))))
(%%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
(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 %%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))
)
(* 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))))
(%%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) (* 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) (* 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) (* 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
LOGEQV LOGIOR FLOAT-SIGN FROUND FTRUNCATE FCEILING FFLOOR ROUND CEILING TRUNCATE CL:FLOOR
LCM CL:GCD CL:* + /= ODDP EVENP %%COMPLEX-PRINT COMPLEX %%RATIONALIZE-FLOAT)
)
(PUTPROPS CMLARITH COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (11656 15755 (ISQRT 11666 . 13096) (PRIMEP 13098 . 13998) (PHASE 14000 . 14569) (SIGNUM
14571 . 15436) (%%SIGNUM 15438 . 15753)) (16137 29081 (NUMERATOR 16147 . 16535) (DENOMINATOR 16537 .
16926) (RATIONALP 16928 . 17091) (RATIONAL 17093 . 18526) (RATIONALIZE 18528 . 19447) (%%RATIO-PRINT
19449 . 21047) (%%BUILD-RATIO 21049 . 22141) (%%RATIONALIZE-FLOAT 22143 . 23480) (%%RATIO* 23482 .
24118) (%%RATIO/ 24120 . 24625) (%%RATIO-TIMES-QUOTIENT 24627 . 25341) (%%RATIO+ 25343 . 25768) (
%%RATIO- 25770 . 25849) (%%RATIO-PLUS-DIFFERENCE 25851 . 27085) (%%RATIO-INTEGER* 27087 . 28031) (
%%RATIO-INTEGER+ 28033 . 28519) (%%RATIO-INTEGER- 28521 . 29079)) (29552 34313 (COMPLEX 29562 . 30635)
(REALPART 30637 . 30847) (IMAGPART 30849 . 31082) (%%COMPLEX+ 31084 . 31344) (%%COMPLEX- 31346 .
31609) (%%COMPLEX* 31611 . 32059) (%%COMPLEX/ 32061 . 32803) (%%COMPLEX-ABS 32805 . 33094) (
%%COMPLEX-MINUS 33096 . 33303) (%%COMPLEX-TIMESI 33305 . 33695) (CONJUGATE 33697 . 33991) (
%%COMPLEX-PRINT 33993 . 34311)) (34445 34593 (NEW-MINUSP 34455 . 34591)) (34675 34824 (CL:ZEROP 34685
. 34822)) (34825 35280 (EVENP 34835 . 34987) (ODDP 34989 . 35143) (PLUSP 35145 . 35278)) (35332 39184
(%%= 35342 . 37779) (%%> 37781 . 39182)) (39185 43724 (= 39195 . 39370) (%%= 39372 . 41809) (/= 41811
. 42091) (< 42093 . 42500) (> 42502 . 42886) (<= 42888 . 43290) (>= 43292 . 43722)) (50581 55071 (+
50591 . 51217) (- 51219 . 51720) (CL:* 51722 . 52156) (/ 52158 . 52450) (%%/ 52452 . 54813) (1+ 54815
. 54941) (1- 54943 . 55069)) (57498 61891 (CL:GCD 57508 . 58918) (%%GCD 58920 . 60424) (LCM 60426 .
61889)) (62068 64097 (FLOAT 62078 . 62318) (\FLOAT 62320 . 64095)) (64174 72650 (CL:FLOOR 64184 .
65352) (TRUNCATE 65354 . 67565) (CEILING 67567 . 68660) (ROUND 68662 . 70385) (CL:MOD 70387 . 70891) (
REM 70893 . 71223) (FFLOOR 71225 . 71580) (FCEILING 71582 . 71937) (FTRUNCATE 71939 . 72297) (FROUND
72299 . 72648)) (72685 75419 (DECODE-FLOAT 72695 . 73396) (SCALE-FLOAT 73398 . 74123) (FLOAT-RADIX
74125 . 74291) (FLOAT-SIGN 74293 . 74540) (FLOAT-DIGITS 74542 . 74770) (FLOAT-PRECISION 74772 . 74984)
(INTEGER-DECODE-FLOAT 74986 . 75417)) (75976 77579 (NEW-LESSP 75986 . 76116) (NEW-EQP 76118 . 76705)
(NEW-ABS 76707 . 77445) (NEW-MINUS 77447 . 77577)) (88854 97104 (NEW-SLOWIPLUS2 88864 . 90410) (
NEW-SLOWIDIFFERENCE 90412 . 92725) (NEW-SLOWITIMES2 92727 . 96222) (NEW-SLOWIQUOTIENT 96224 . 96408) (
NEW-IREMAINDER 96410 . 96563) (NEW-SLOWIGREATERP 96565 . 97102)) (98153 106086 (%%+ 98163 . 100004) (
%%- 100006 . 101945) (%%* 101947 . 103721) (%%/ 103723 . 106084)) (106544 108828 (LOGIOR 106554 .
107481) (LOGEQV 107483 . 107854) (LOGNAND 107856 . 108011) (LOGNOR 108013 . 108166) (LOGANDC1 108168
. 108340) (LOGANDC2 108342 . 108498) (LOGORC1 108500 . 108670) (LOGORC2 108672 . 108826)) (108875
109719 (BOOLE 108885 . 109717)) (110181 110538 (LOGTEST 110191 . 110368) (LOGBITP 110370 . 110536)) (
110539 111012 (ASH 110549 . 111010)) (111013 113396 (LOGCOUNT 111023 . 112491) (%%LOGCOUNT 112493 .
113394)) (113397 115470 (INTEGER-LENGTH 113407 . 115468)) (115594 115963 (BYTE-SIZE 115604 . 115778) (
BYTE-POSITION 115780 . 115961)) (116029 116528 (LDB-TEST 116039 . 116224) (MASK-FIELD 116226 . 116526)
) (116594 116903 (DEPOSIT-FIELD 116604 . 116901)))))
STOP