(FILECREATED " 5-Aug-86 12:11:32" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;24 89569
changes to: (VARS CMLARITHCOMS)
previous date: " 7-Jul-86 12:41:26" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;21)
(* 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."
)
(COMS (* "misc")
(FNS ISQRT PRIMEP PHASE SIGNUM %%SIGNUM))
(COMS (* "Section 2.1.2 Ratios.")
(STRUCTURES RATIO)
(FNS \RATIO.DEFPRINT)
[DECLARE: DONTEVAL@LOAD DOCOPY (P (* "the following makes NUMBERP true on ratios")
(\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE RATIO))
(LOGOR \TT.NUMBERP \TT.ATOM))
(DEFPRINT (QUOTE RATIO)
(QUOTE \RATIO.DEFPRINT]
(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 close enough")
(FUNCTIONS CL:ZEROP)
(FNS EVENP ODDP PLUSP))
(COMS (* "Section 12.4 Arithmetic Operations.")
(FNS + - CL:* / %%/ 1+ 1-)
(PROP DMACRO + - CL:* / 1+ 1-)
(* "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."
)
(* "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 (* "Section 12.3 Comparisons on Numbers.")
(FNS %%= %%>)
(FNS = %%= /= < > <= >=)
(PROP DMACRO = /= < > <= >=)
(* "MAX and MIN are OK"))
[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)
(VARIABLES BOOLE-CLR BOOLE-SET BOOLE-1 BOOLE-2 BOOLE-C1 BOOLE-C2 BOOLE-AND BOOLE-IOR
BOOLE-XOR BOOLE-EQV BOOLE-NAND BOOLE-NOR BOOLE-ANDC1 BOOLE-ANDC2 BOOLE-ORC1
BOOLE-ORC2)
(* "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))
(COMS (*
"Section 12.10, implementation parameters. The constants in this COMS are exported to the user."
)
(FUNCTIONS **FLOAT**)
(VARIABLES MOST-POSITIVE-FIXNUM MOST-NEGATIVE-FIXNUM MOST-POSITIVE-SINGLE-FLOAT
LEAST-POSITIVE-SINGLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT
MOST-NEGATIVE-SINGLE-FLOAT MOST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SHORT-FLOAT
LEAST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SHORT-FLOAT MOST-POSITIVE-DOUBLE-FLOAT
LEAST-POSITIVE-DOUBLE-FLOAT LEAST-NEGATIVE-DOUBLE-FLOAT
MOST-NEGATIVE-DOUBLE-FLOAT MOST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-LONG-FLOAT
LEAST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-LONG-FLOAT)
(* "EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON)))"
)
(VARIABLES SINGLE-FLOAT-EPSILON SHORT-FLOAT-EPSILON DOUBLE-FLOAT-EPSILON
LONG-FLOAT-EPSILON)
(* "NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON)))"
)
(VARIABLES SINGLE-FLOAT-NEGATIVE-EPSILON SHORT-FLOAT-NEGATIVE-EPSILON
DOUBLE-FLOAT-NEGATIVE-EPSILON LONG-FLOAT-NEGATIVE-EPSILON))
(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 LCM %%GCD
CL:GCD / CL:* - + PLUSP ODDP EVENP \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."
)
(* "misc")
(DEFINEQ
(ISQRT
(CL:LAMBDA (N) (* kbr: " 1-Apr-86 12:11")
(* 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 N)
(NOT (MINUSP N)))
[CL:DO* [(LG (INTEGER-LENGTH N))
(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)
N)
(SETQ LO MID)
(SETQ HI MID]
(CL:ERROR "Isqrt: ~S argument must be a nonnegative integer" N))))
(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)
(COND
((COMPLEXP NUMBER)
(CL:ATAN (COMPLEX-IMAGPART NUMBER)
(COMPLEX-REALPART NUMBER)))
((MINUSP NUMBER)
PI)
(T 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))
(DEFINEQ
(\RATIO.DEFPRINT
[LAMBDA (NUMBER STREAM) (* bvm: " 3-Aug-86 16:08")
[LET ((TOP (NUMERATOR NUMBER))
(BOTTOM (DENOMINATOR NUMBER)))
(if (NOT (fetch (READTABLEP COMMONNUMSYNTAX) of *READTABLE*))
then (* Can't print nice ratios to old read
tables)
(PRIN1 "|." STREAM)
(\PRINDATUM (LIST (QUOTE /)
TOP BOTTOM)
STREAM)
else (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])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(* "the following makes NUMBERP true on ratios")
(\SETTYPEMASK (\TYPENUMBERFROMNAME (QUOTE RATIO))
(LOGOR \TT.NUMBERP \TT.ATOM))
(DEFPRINT (QUOTE RATIO)
(QUOTE \RATIO.DEFPRINT))
)
(DEFINEQ
(NUMERATOR
[CL:LAMBDA (X) (* lmm "22-May-86 15:44")
(* Returns the numerator of a
rational.)
(ETYPECASE X (INTEGER X)
(RATIO (RATIO-NUMERATOR X])
(DENOMINATOR
[CL:LAMBDA (X) (* lmm "22-May-86 15:43")
(* Returns the denominator of a
rational. *)
(ETYPECASE X (INTEGER 1)
(RATIO (RATIO-DENOMINATOR X])
(%%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 (X) (* lmm "19-Jun-86 14:42")
(* Rationalize does a rational, but it
assumes that floats are only accurate
to their precision, and generates a
good rational aproximation of them.
*)
(ETYPECASE X ((OR INTEGER RATIO)
X)
(FLOAT (%%RATIONALIZE-FLOAT X SINGLE-FLOAT-EPSILON))
(COMPLEX (%%MAKE-COMPLEX (RATIONALIZE (REALPART X))
(RATIONALIZE (IMAGPART X])
(%%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)) (* lmm "27-Jun-86 22:34")
(* Builds a complex number from the
specified components.
*)
(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 close enough")
(DEFUN CL:ZEROP (NUMBER) (= 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.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 (X) (* kbr: "10-Apr-86 23:50")
(+ X 1])
(1-
[LAMBDA (X) (* kbr: "10-Apr-86 23:50")
(- X 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)) )
)
(* "CONJUGATE implemented in section 2.1.4 above.")
(DEFINEQ
(CL:GCD
(CL:LAMBDA (&OPTIONAL (INTEGER1 0)
(INTEGER2 0)
&REST INTEGERS) (* kbr: " 8-Apr-86 20:34")
(* 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 *)
(CL:DO* ((RES (%%GCD INTEGER1 INTEGER2)
(%%GCD RES (CAR INTEGERS)))
(INTEGERS INTEGERS (CDR INTEGERS)))
((OR (NULL INTEGERS)
(= RES 1))
RES))))
(%%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 (ARG1 &REST ARGS)
(* 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.
Timings show time is saved by avoiding division when CL:GCD=1.
*)
(* Returns the least common multiple
of one or more integers.
*)
(CL:DO* ((ARG NIL (CAR ARGS))
(CL:GCD NIL (%%GCD ARG RES))
[RES ARG1 (CL:* ARG (CL:IF (= CL:GCD 1)
RES
(/ RES CL:GCD]
(ARGS ARGS (CDR ARGS)))
((OR (NULL ARGS)
(ZEROP RES))
RES))))
)
(* "Section 12.6 Type Conversions and Component Extractions on Numbers.")
(* * "LLFLOAT replacements. LLFLOAT ufns seem OK once we modify \FLOAT appropriately.")
(* "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)) (* lmm "27-Jun-86 22:39")
(* 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 (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)
&AUX THRESH) (* Rounds number (or number/divisor)
to nearest integer. The second
returned value is the remainder.
*)
(MULTIPLE-VALUE-BIND (TRU REM)
(TRUNCATE NUMBER DIVISOR)
(CL:IF DIVP (SETQ THRESH (/ (ABS DIVISOR)
2))
(SETQ THRESH .5))
(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 (F) (* kbr: " 7-Apr-86 20:48")
(VALUES (create FLOATP
SIGNBIT ← (fetch (FLOATP SIGNBIT) of F)
EXPONENT ← (SUB1 \EXPONENT.BIAS)
HIFRACTION ← (fetch (FLOATP HIFRACTION) of F)
LOFRACTION ← (fetch (FLOATP LOFRACTION) of F))
(IDIFFERENCE (fetch (FLOATP EXPONENT) of F)
(SUB1 \EXPONENT.BIAS))
(COND
((EQ (fetch (FLOATP SIGNBIT) of F)
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 (F)
(CL:DECLARE (IGNORE F))
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 (F) (* kbr: "11-Apr-86 00:03")
(TYPECASE F (SINGLE-FLOAT 23)
(T (CL:ERROR "Float-digits: ~A not a float" F])
(FLOAT-PRECISION
(CL:LAMBDA (F)
(CL:IF (ZEROP F)
0
(FLOAT-DIGITS F))))
(INTEGER-DECODE-FLOAT
[CL:LAMBDA (X)
(LET ((PRECISION (FLOAT-PRECISION X)))
(MULTIPLE-VALUE-BIND (F E S)
(DECODE-FLOAT X)
(VALUES (TRUNCATE (SCALE-FLOAT F PRECISION))
(- E PRECISION)
S])
)
(* "EXPT COMPLEX REALPART and IMAGPART are defined by CMLFLOAT.")
(* "Section 12.3 Comparisons on Numbers.")
(DEFINEQ
(%%=
[LAMBDA (X Y) (* lmm "27-Jun-86 23: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 (%%= 0 (COMPLEX-IMAGPART Y))
(%%= X (COMPLEX-REALPART 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 (%%= (COMPLEX-IMAGPART Y)
0)
(%%= X (COMPLEX-REALPART Y]
[FLOAT (CTYPECASE Y (FLOAT (* EQL failed)
NIL)
((OR INTEGER RATIO)
(FEQP X Y))
(COMPLEX (AND (%%= (COMPLEX-IMAGPART Y)
0)
(%%= X (COMPLEX-REALPART Y]
(COMPLEX (CTYPECASE Y [COMPLEX (AND (%%= (COMPLEX-REALPART X)
(COMPLEX-REALPART Y))
(%%= (COMPLEX-IMAGPART X)
(COMPLEX-IMAGPART Y]
(NUMBER (AND (%%= (COMPLEX-IMAGPART X)
0)
(%%= (COMPLEX-REALPART X)
Y])
(%%>
[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) (* lmm "16-Jul-85 16:51")
(for X in MORE-NUMBERS always (%%= NUMBER X))))
(%%=
[LAMBDA (X Y) (* lmm "27-Jun-86 23: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 (%%= 0 (COMPLEX-IMAGPART Y))
(%%= X (COMPLEX-REALPART 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 (%%= (COMPLEX-IMAGPART Y)
0)
(%%= X (COMPLEX-REALPART Y]
[FLOAT (CTYPECASE Y (FLOAT (* EQL failed)
NIL)
((OR INTEGER RATIO)
(FEQP X Y))
(COMPLEX (AND (%%= (COMPLEX-IMAGPART Y)
0)
(%%= X (COMPLEX-REALPART Y]
(COMPLEX (CTYPECASE Y [COMPLEX (AND (%%= (COMPLEX-REALPART X)
(COMPLEX-REALPART Y))
(%%= (COMPLEX-IMAGPART X)
(COMPLEX-IMAGPART Y]
(NUMBER (AND (%%= (COMPLEX-IMAGPART X)
0)
(%%= (COMPLEX-REALPART X)
Y])
(/=
[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 (&REST MORE-NUMBERS) (* lmm "19-Jun-86 17:13")
(for X on MORE-NUMBERS while (CDR X) always (> (CADR X)
(CAR X])
(>
[CL:LAMBDA (&REST MORE-NUMBERS) (* lmm "19-Jun-86 17:15")
(for X on MORE-NUMBERS while (CDR X) always (%%> (CAR X)
(CADR X])
(<=
[CL:LAMBDA (&REST MORE-NUMBERS) (* lmm "16-Jul-85 17:18")
(for X on MORE-NUMBERS while (CDR X) always (LEQ (CAR X)
(CADR X])
(>=
[CL:LAMBDA (&REST MORE-NUMBERS) (* lmm "19-Jun-86 16:58")
(for X on MORE-NUMBERS while (CDR X) always (NOT (< (CAR X)
(CADR X])
)
(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")
(* "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) (* lmm "19-Jun-86 15:39")
(\CALLME (QUOTE +)) (* UFN for + Microcode generally
handles the case of two args both
FIXPs)
(PROG NIL
LOOP
(RETURN (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)))
(SINGLE-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:41")
(\CALLME (QUOTE -)) (* UFN for -
Microcode generally handles the case
of two args both FIXPs)
(CTYPECASE N1 [INTEGER (CTYPECASE N2 (INTEGER (IDIFFERENCE N1 N2))
(SINGLE-FLOAT (FDIFFERENCE N1 N2))
(RATIO (%%RATIO- (%%MAKE-RATIO N1 1)
N2))
(COMPLEX (%%COMPLEX- (%%MAKE-COMPLEX N1 0)
N2]
[FLOAT (CTYPECASE N2 ((OR INTEGER SINGLE-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))))
)
(DEFCONSTANT BOOLE-CLR 0)
(DEFCONSTANT BOOLE-SET 1)
(DEFCONSTANT BOOLE-1 2)
(DEFCONSTANT BOOLE-2 3)
(DEFCONSTANT BOOLE-C1 4)
(DEFCONSTANT BOOLE-C2 5)
(DEFCONSTANT BOOLE-AND 6)
(DEFCONSTANT BOOLE-IOR 7)
(DEFCONSTANT BOOLE-XOR 8)
(DEFCONSTANT BOOLE-EQV 9)
(DEFCONSTANT BOOLE-NAND 10)
(DEFCONSTANT BOOLE-NOR 11)
(DEFCONSTANT BOOLE-ANDC1 12)
(DEFCONSTANT BOOLE-ANDC2 13)
(DEFCONSTANT BOOLE-ORC1 14)
(DEFCONSTANT 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 (X N) (* lmm "12-Apr-85 07:55")
(COND
[(ILEQ N 0)
(COND
((EQ N 0)
X)
(T (RSH X (IMINUS N]
((EQ X 0)
0)
((IGREATERP N (CONSTANT (INTEGERLENGTH MAX.FIXP)))
(\BIGNUM.LSH X N))
(T (FRPTQ N (SETQ X (IPLUS X X)))
X])
)
(DEFINEQ
(LOGCOUNT
[CL:LAMBDA (X) (* kbr: "10-Apr-86 17:38")
(* Logcount returns the number of bits
that are the complement of the sign in
the integer argument x.
*)
(* If X is negative, then the number
of 0 bits is returned, otherwise
number of 1 bits is returned.
*)
(COND
((OR (SMALLP X)
(FIXP X))
(%%LOGCOUNT (CL:IF (MINUSP X)
(LOGNOT X)
X)))
((type? BIGNUM X)
(for ELEMENT in (fetch (BIGNUM ELEMENTS) of (CL:IF (MINUSP X)
(LOGNOT X)
X)) sum (%%LOGCOUNT ELEMENT)))
(T (CL:ERROR "Argument not integer, ~A." X])
(%%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 (X) (* lmm "28-Jun-86 20:33")
(if (< X 0)
then (SETQ X (- -1 X)))
(MACROLET [(NBITS.OR.LESS (X N)
(BQUOTE (< (\, X)
(\, (ASH 1 N]
(COND
((NBITS.OR.LESS X 16)
(COND
((NBITS.OR.LESS X 8)
(COND
((NBITS.OR.LESS X 4)
(COND
((NBITS.OR.LESS X 2)
(COND
((NBITS.OR.LESS X 1)
(COND
((EQ X 0)
0)
(T 1)))
(T 2)))
((NBITS.OR.LESS X 3)
3)
(T 4)))
((NBITS.OR.LESS X 6)
(COND
((NBITS.OR.LESS X 5)
5)
(T 6)))
((NBITS.OR.LESS X 7)
7)
(T 8)))
((NBITS.OR.LESS X 12)
(COND
((NBITS.OR.LESS X 10)
(COND
((NBITS.OR.LESS X 9)
9)
(T 10)))
((NBITS.OR.LESS X 11)
11)
(T 12)))
((NBITS.OR.LESS X 14)
(COND
((NBITS.OR.LESS X 13)
13)
(T 14)))
((NBITS.OR.LESS X 15)
15)
(T 16)))
(T (+ 16 (INTEGER-LENGTH (ASH X -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)))
)
(*
"Section 12.10, implementation parameters. The constants in this COMS are exported to the user."
)
(DEFUN **FLOAT** (F E) (SCALE-FLOAT (DECODE-FLOAT (FLOAT F))
E))
(DEFCONSTANT MOST-POSITIVE-FIXNUM 65535)
(DEFCONSTANT MOST-NEGATIVE-FIXNUM -65536)
(DEFCONSTANT MOST-POSITIVE-SINGLE-FLOAT 3.402823E38)
(DEFCONSTANT LEAST-POSITIVE-SINGLE-FLOAT (**FLOAT** 1 -125) )
(DEFCONSTANT LEAST-NEGATIVE-SINGLE-FLOAT (**FLOAT** -1 -125) )
(DEFCONSTANT MOST-NEGATIVE-SINGLE-FLOAT -3.402823E38)
(DEFCONSTANT MOST-POSITIVE-SHORT-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
(DEFCONSTANT LEAST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
(DEFCONSTANT LEAST-NEGATIVE-SHORT-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
(DEFCONSTANT MOST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
(DEFCONSTANT MOST-POSITIVE-DOUBLE-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
(DEFCONSTANT LEAST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
(DEFCONSTANT LEAST-NEGATIVE-DOUBLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
(DEFCONSTANT MOST-NEGATIVE-DOUBLE-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
(DEFCONSTANT MOST-POSITIVE-LONG-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
(DEFCONSTANT LEAST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
(DEFCONSTANT LEAST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
(DEFCONSTANT MOST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
(*
"EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON)))"
)
(DEFCONSTANT SINGLE-FLOAT-EPSILON (**FLOAT** 1 -22) )
(DEFCONSTANT SHORT-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
(DEFCONSTANT DOUBLE-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
(DEFCONSTANT LONG-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
(*
"NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON)))"
)
(DEFCONSTANT SINGLE-FLOAT-NEGATIVE-EPSILON (**FLOAT** 1 -23) )
(DEFCONSTANT SHORT-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
(DEFCONSTANT DOUBLE-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
(DEFCONSTANT LONG-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
(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 LCM %%GCD
CL:GCD / CL:* - + PLUSP ODDP EVENP \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 (8823 12535 (ISQRT 8833 . 10222) (PRIMEP 10224 . 11119) (PHASE 11121 . 11362) (SIGNUM
11364 . 12223) (%%SIGNUM 12225 . 12533)) (12700 14319 (\RATIO.DEFPRINT 12710 . 14317)) (14546 25678 (
NUMERATOR 14556 . 14915) (DENOMINATOR 14917 . 15284) (%%BUILD-RATIO 15286 . 16358) (RATIONALP 16360 .
16521) (RATIONAL 16523 . 17943) (RATIONALIZE 17945 . 18824) (%%RATIONALIZE-FLOAT 18826 . 20146) (
%%RATIO* 20148 . 20784) (%%RATIO/ 20786 . 21288) (%%RATIO-TIMES-QUOTIENT 21290 . 21982) (%%RATIO+
21984 . 22409) (%%RATIO- 22411 . 22490) (%%RATIO-PLUS-DIFFERENCE 22492 . 23709) (%%RATIO-INTEGER*
23711 . 24644) (%%RATIO-INTEGER+ 24646 . 25124) (%%RATIO-INTEGER- 25126 . 25676)) (26148 30727 (
COMPLEX 26158 . 27088) (REALPART 27090 . 27300) (IMAGPART 27302 . 27535) (%%COMPLEX+ 27537 . 27794) (
%%COMPLEX- 27796 . 28056) (%%COMPLEX* 28058 . 28502) (%%COMPLEX/ 28504 . 29242) (%%COMPLEX-ABS 29244
. 29525) (%%COMPLEX-MINUS 29527 . 29731) (%%COMPLEX-TIMESI 29733 . 30123) (CONJUGATE 30125 . 30410) (
\PRINT.COMPLEX 30412 . 30725)) (30859 31314 (EVENP 30869 . 31021) (ODDP 31023 . 31177) (PLUSP 31179 .
31312)) (31365 35796 (+ 31375 . 31999) (- 32001 . 32500) (CL:* 32502 . 32934) (/ 32936 . 33224) (%%/
33226 . 35550) (1+ 35552 . 35672) (1- 35674 . 35794)) (37945 41452 (CL:GCD 37955 . 38916) (%%GCD 38918
. 40407) (LCM 40409 . 41450)) (41706 49798 (CL:FLOOR 41716 . 42881) (TRUNCATE 42883 . 44877) (CEILING
44879 . 45969) (ROUND 45971 . 47537) (CL:MOD 47539 . 48039) (REM 48041 . 48371) (FFLOOR 48373 . 48728
) (FCEILING 48730 . 49085) (FTRUNCATE 49087 . 49445) (FROUND 49447 . 49796)) (49833 52291 (
DECODE-FLOAT 49843 . 50557) (SCALE-FLOAT 50559 . 51283) (FLOAT-RADIX 51285 . 51364) (FLOAT-SIGN 51366
. 51613) (FLOAT-DIGITS 51615 . 51831) (FLOAT-PRECISION 51833 . 51954) (INTEGER-DECODE-FLOAT 51956 .
52289)) (52417 56242 (%%= 52427 . 54837) (%%> 54839 . 56240)) (56243 60145 (= 56253 . 56427) (%%=
56429 . 58839) (/= 58841 . 59117) (< 59119 . 59370) (> 59372 . 59627) (<= 59629 . 59881) (>= 59883 .
60143)) (67278 75424 (%%+ 67288 . 69435) (%%- 69437 . 71360) (%%* 71362 . 73096) (%%/ 73098 . 75422))
(75883 78163 (LOGIOR 75893 . 76820) (LOGEQV 76822 . 77189) (LOGNAND 77191 . 77346) (LOGNOR 77348 .
77501) (LOGANDC1 77503 . 77675) (LOGANDC2 77677 . 77833) (LOGORC1 77835 . 78005) (LOGORC2 78007 .
78161)) (78210 79054 (BOOLE 78220 . 79052)) (79612 79969 (LOGTEST 79622 . 79799) (LOGBITP 79801 .
79967)) (79970 80364 (ASH 79980 . 80362)) (80365 82676 (LOGCOUNT 80375 . 81773) (%%LOGCOUNT 81775 .
82674)) (82677 84602 (INTEGER-LENGTH 82687 . 84600)) (84727 85096 (BYTE-SIZE 84737 . 84911) (
BYTE-POSITION 84913 . 85094)) (85163 85662 (LDB-TEST 85173 . 85358) (MASK-FIELD 85360 . 85660)) (85729
86038 (DEPOSIT-FIELD 85739 . 86036)))))
STOP