(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")

(IL:FILECREATED "24-Mar-92 14:23:15" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLARITH.;2|
 68401  

      IL:|changes| IL:|to:|  (IL:VARS IL:CMLARITHCOMS) (IL:FUNCTIONS CL:UPGRADED-COMPLEX-PART-TYPE) (IL:FNS LCM)

      IL:|previous| IL:|date:| "16-May-90 12:46:36" 
IL:|{DSK}<usr>local>lde>lispcore>sources>CMLARITH.;1|)


; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:CMLARITHCOMS)

(IL:RPAQQ IL:CMLARITHCOMS ((IL:* IL:|;;;| "Common Lisp Arithmetic ") (IL:COMS (IL:* IL:|;;| "Error utilities") (IL:FUNCTIONS %NOT-NUMBER-ERROR %NOT-NONCOMPLEX-NUMBER-ERROR %NOT-INTEGER-ERROR %NOT-RATIONAL-ERROR %NOT-FLOAT-ERROR)) (IL:COMS (IL:* IL:|;;;| "Section 2.1.2 Ratios. ") (IL:COMS (IL:STRUCTURES RATIO) (IL:* IL:|;;| "The following makes NUMBERP true on ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE RATIO)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))))) (IL:FUNCTIONS DENOMINATOR NUMERATOR RATIONALP %RATIO-PRINT %BUILD-RATIO RATIONAL RATIONALIZE) (IL:FUNCTIONS %RATIO-PLUS %RATIO-TIMES)) (IL:COMS (IL:* IL:|;;;| "Section 2.1.4 Complex Numbers.") (IL:COMS (IL:STRUCTURES COMPLEX) (IL:* IL:|;;| "So we don't inherit the deftype from defstruct") (IL:TYPES COMPLEX) (IL:* IL:|;;| "Make Complex  NUMBERP") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE COMPLEX)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))))) (IL:FUNCTIONS COMPLEX REALPART IMAGPART CONJUGATE PHASE CL:UPGRADED-COMPLEX-PART-TYPE %COMPLEX-PRINT %COMPLEX-+ %COMPLEX-- %COMPLEX-* %COMPLEX-/ %COMPLEX-ABS)) (IL:COMS (IL:* IL:|;;;| "Datatype predicates") (IL:* IL:|;;| "cl:integerp is defined in cmlpred (has an optimizer)") (IL:* IL:|;;| "cl:floatp is defined in cmltypes (has an optimizer). il:floatp is defined on llbasic") (IL:* IL:|;;| "cl:complexp is a defstruct predicate (compiles in line)") (IL:* IL:|;;| "cl:numberp is defined in cmltypes (has an optimizer). il:numberp is defined on llbasic")) (IL:COMS (IL:* IL:|;;;| "Section 12.2 Predicates on Numbers (generic).") (IL:* IL:|;;| "cl:zerop  is not shared with il:zerop, although they are equivalent. There is no il;plusp ") (IL:COMS (IL:FUNCTIONS ZEROP PLUSP) (XCL:OPTIMIZERS ZEROP PLUSP)) (IL:* IL:|;;| "cl:minusp is shared with il:minusp, but must be redefined to work with ratios. Old version resides in llarith") (IL:COMS (IL:FUNCTIONS MINUSP) (XCL:OPTIMIZERS MINUSP)) (IL:* IL:|;;| "Both cl:evenp and cl:oddp are shared with il:. The functions are extended by allowing a second optional modulus argument. Another version of il:oddp exists on llarith, but the definition of il:evenp has disappeared") (IL:COMS (IL:FUNCTIONS EVENP ODDP) (XCL:OPTIMIZERS EVENP ODDP))) (IL:COMS (IL:* IL:|;;;| "Section 12.3 Comparisons on Numbers. (generic)") (IL:COMS (IL:FUNCTIONS %= %/= %> %< %>= %<=) (IL:PROP IL:DOPVAL %= %> %<) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO %> %< %>= %<=) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:|;;| "Backward compatibility") (IL:* IL:\; " il:%= is listed as the punt function for the = opcode") (IL:MOVD (QUOTE %=) (QUOTE IL:%=)) (IL:* IL:\; "Greaterp is the UFN for the greaterp opcode. Effectively redefines the opcode") (IL:MOVD (QUOTE %>) (QUOTE IL:GREATERP)) (IL:* IL:\; "Interlisp Greaterp and Lessp are defined in llarith") (IL:MOVD (QUOTE %<) (QUOTE IL:LESSP))))) (IL:* IL:|;;| "=, <, >, <=, and >= are shared with il:, but cl:/= is NOT shared (?!)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %COMPARISON-MACRO)) (IL:FNS = /= < > <= >=) (IL:FUNCTIONS %COMPARISON-OPTIMIZER) (XCL:OPTIMIZERS = /= < > <= >=)) (IL:* IL:|;;| "Note: the related predicates EQL, EQUAL, and EQUALP should be consulted if any of the above change. EQL is on LLNEW (?), EQUAL and EQUALP on CMLTYPES.") (IL:* IL:|;;| "cl:min and cl:max are shared with il: (defined in llarith). They  are written in terms of GREATERP and hence work on ratios. Note (min) returns #.max.integer , which is an extension on the CLtl spec. We only optimize the case of two args") (XCL:OPTIMIZERS MIN MAX)) (IL:COMS (IL:* IL:|;;;| "Section 12.4 Arithmetic Operations (generic). ") (IL:COMS (IL:FUNCTIONS %+ %- %* %/) (IL:* IL:\; "NOTE: %/ cannot compile out to the existinq quotient opcode because it produces ratios rather than truncating") (IL:PROP IL:DOPVAL %+ %- %*) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO %+ %- %*) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:|;;| "Backward compatibility") (IL:MOVD (QUOTE %/) (QUOTE IL:%/)) (IL:* IL:|;;| "Redefine UFNs for generic plus, difference, and times. Old UFN defined in llarith.") (IL:MOVD (QUOTE %+) (QUOTE IL:\\SLOWPLUS2)) (IL:MOVD (QUOTE %-) (QUOTE IL:\\SLOWDIFFERENCE)) (IL:MOVD (QUOTE %*) (QUOTE IL:\\SLOWTIMES2))))) (IL:COMS (IL:FNS + - * /) (IL:FUNCTIONS 1+ 1- %RECIPROCOL) (XCL:OPTIMIZERS + - * / 1+ 1-) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO + *) (IL:* IL:|;;| "Redefine Interlisp generic arithmetic to work with ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:MOVD (QUOTE +) (QUOTE IL:PLUS)) (IL:* IL:|;;| "Don't need to redefine difference since it is defined in terms of the difference opcode (redefined above)") (IL:MOVD (QUOTE *) (QUOTE IL:TIMES)) (IL:* IL:|;;| "So Interlisp quotient will do something reasonable with ratios") (IL:* (IL:MOVD (QUOTE IL:NEW-QUOTIENT) (QUOTE IL:QUOTIENT))) (IL:* IL:|;;| "because QUOTIENT is already defined in LLARITH to do something useful with ratios. AR 8062.")))) (IL:* IL:|;;| "INCF and DECF implemented by CMLSETF.") (IL:FUNCTIONS %GCD %LCM) (IL:FNS GCD LCM)) (IL:COMS (IL:* IL:|;;| "Optimizers for Interlisp functions, so that they compile open with the PavCompiler.") (IL:* IL:|;;| "optimizer of IL:minus") (XCL:OPTIMIZERS IL:MINUS) (XCL:OPTIMIZERS IL:PLUS IL:IPLUS IL:FPLUS IL:TIMES IL:ITIMES IL:FTIMES IL:RSH) (IL:PROP IL:DOPVAL IL:PLUS2 IL:IPLUS2 IL:FPLUS2 IL:TIMES2 IL:ITIMES2 IL:FTIMES2)) (IL:COMS (IL:* IL:|;;;| "Section 12.5 Irrational and Transcendental functions. Most of these will be found on cmlfloat.") (IL:FUNCTIONS ISQRT) (IL:* IL:|;;| "Abs is shared with il: abs ia also defined in llarith.") (IL:FUNCTIONS ABS %ABS) (IL:FUNCTIONS SIGNUM %SIGNUM)) (IL:COMS (IL:* IL:|;;;| "Section 12.6 Type Conversions and Component Extractions on Numbers.") (IL:* IL:|;;| "Float implemented in cmlfloat  ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:UNBOXEDOPS)) (IL:* IL:\; "These should be exported from xcl") (IL:COMS (IL:FUNCTIONS XCL::STRUNCATE XCL::SFLOOR XCL::SCEILING XCL::SROUND) (XCL:OPTIMIZERS XCL::STRUNCATE XCL::SROUND)) (IL:* IL:\; "Round is shared with il: (?!)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %INTEGER-COERCE-MACRO)) (IL:FUNCTIONS TRUNCATE FLOOR CEILING ROUND) (IL:FUNCTIONS %INTEGER-COERCE-OPTIMIZER) (XCL:OPTIMIZERS TRUNCATE FLOOR CEILING ROUND)) (IL:COMS (IL:FUNCTIONS FTRUNCATE FFLOOR FCEILING FROUND) (XCL:OPTIMIZERS FTRUNCATE FFLOOR FCEILING FROUND)) (IL:COMS (IL:FUNCTIONS MOD REM)) (IL:* IL:|;;| "Should IL:remainder be equivalent to cl:rem?. Thereis no IL:mod in the IRM, although it has a macro which makes it equivalent to imod.") (IL:* IL:|;;| "See cmlfloat for ffloor and friends, decode-float and friends")) (IL:COMS (IL:* IL:|;;;| "Section 12.7 Logical Operations on Numbers.") (IL:* IL:|;;| "LOGXOR and LOGAND are shared with IL. (definitions in llarith)") (IL:COMS (IL:FUNCTIONS %LOGICAL-OPTIMIZER) (XCL:OPTIMIZERS LOGXOR LOGAND)) (IL:COMS (IL:FUNCTIONS %LOGIOR %LOGEQV) (IL:PROP IL:DOPVAL %LOGIOR) (IL:* IL:\; "for the byte compiler") (IL:PROP IL:DMACRO %LOGIOR)) (IL:COMS (IL:FNS LOGIOR LOGEQV) (XCL:OPTIMIZERS LOGIOR LOGEQV)) (IL:COMS (IL:FUNCTIONS LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2) (XCL:OPTIMIZERS LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2)) (IL:COMS (IL: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) (IL:FUNCTIONS BOOLE)) (IL:* IL:|;;| "Lognot is shared with IL.(in addarith) ") (IL:COMS (IL:FUNCTIONS LOGTEST LOGBITP) (XCL:OPTIMIZERS LOGTEST)) (IL:COMS (IL:FUNCTIONS ASH) (IL:PROP IL:DOPVAL ASH) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO ASH)) (IL:COMS (IL:FUNCTIONS LOGCOUNT %LOGCOUNT) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES (IL:LOADCOMP) IL:LLBIGNUM)) (IL:* IL:\; "Should be in llbignum") (IL:FUNCTIONS %BIGNUM-LOGCOUNT)) (IL:FUNCTIONS INTEGER-LENGTH) (IL:* IL:|;;| "OPTIMIZERS FOR IL:LLSH AND IL:LRSH") (IL:COMS (IL:FUNCTIONS %LLSH8 %LLSH1 %LRSH8 %LRSH1) (IL:PROP IL:DOPVAL %LLSH8 %LLSH1 %LRSH8 %LRSH1) (XCL:OPTIMIZERS IL:LLSH IL:LRSH))) (IL:COMS (IL:* IL:|;;;| "Section 12.8 Byte Manipulations Functions.") (IL:COMS (IL:FUNCTIONS BYTE BYTE-SIZE BYTE-POSITION) (IL:* IL:|;;| "Byte doesn't need an optimizer since the side-effects data-base will do constant folding, but the byte-compiler can profit from an optimizer") (IL:FUNCTIONS OPTIMIZE-BYTE) (IL:PROP IL:DMACRO BYTE)) (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %MAKE-BYTE-MASK-1 %MAKE-BYTE-MASK-0)) (IL:FUNCTIONS LDB DPB MASK-FIELD DEPOSIT-FIELD) (IL:FUNCTIONS %CONSTANT-BYTESPEC-P) (XCL:OPTIMIZERS LDB DPB MASK-FIELD DEPOSIT-FIELD)) (IL:COMS (IL:FUNCTIONS LDB-TEST) (XCL:OPTIMIZERS LDB-TEST))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:CMLARITH) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA LOGEQV LOGIOR LCM GCD / * - + >= <= > < /= =)))))



(IL:* IL:|;;;| "Common Lisp Arithmetic ")





(IL:* IL:|;;| "Error utilities")



(DEFUN %NOT-NUMBER-ERROR (OBJECT) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE NUMBER) :NAME OBJECT :VALUE OBJECT))

(DEFUN %NOT-NONCOMPLEX-NUMBER-ERROR (OBJECT) (IF (NOT (NUMBERP OBJECT)) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE NUMBER) :NAME OBJECT :VALUE OBJECT) (ERROR "Arg a complex number~%~s" OBJECT)))

(DEFUN %NOT-INTEGER-ERROR (OBJECT) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE INTEGER) :NAME OBJECT :VALUE OBJECT))

(DEFUN %NOT-RATIONAL-ERROR (OBJECT) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE RATIONAL) :VALUE OBJECT :NAME OBJECT))

(DEFUN %NOT-FLOAT-ERROR (OBJECT) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE FLOAT) :NAME OBJECT :VALUE OBJECT))



(IL:* IL:|;;;| "Section 2.1.2 Ratios. ")



(DEFSTRUCT (RATIO (:CONSTRUCTOR %MAKE-RATIO (NUMERATOR DENOMINATOR)) (:PREDICATE %RATIO-P) (:COPIER NIL) (:PRINT-FUNCTION %RATIO-PRINT)) (NUMERATOR :READ-ONLY) (DENOMINATOR :READ-ONLY))



(IL:* IL:|;;| "The following makes NUMBERP true on ratios")


(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 

(IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE RATIO)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))
)

(DEFUN DENOMINATOR (RATIONAL) (IL:* IL:|;;| "Returns the denominator of a rational.  ") (TYPECASE RATIONAL (RATIO (RATIO-DENOMINATOR RATIONAL)) (INTEGER 1) (T (%NOT-RATIONAL-ERROR RATIONAL))))

(DEFUN NUMERATOR (RATIONAL) (IL:* IL:|;;| "Returns the numerator of a rational.") (TYPECASE RATIONAL (RATIO (RATIO-NUMERATOR RATIONAL)) (INTEGER RATIONAL) (T (%NOT-RATIONAL-ERROR RATIONAL))))

(XCL:DEFINLINE RATIONALP (NUMBER) (OR (INTEGERP NUMBER) (%RATIO-P NUMBER)))

(DEFUN %RATIO-PRINT (NUMBER STREAM) (LET ((TOP (RATIO-NUMERATOR NUMBER)) (BOTTOM (RATIO-DENOMINATOR NUMBER)) PR) (COND ((NOT (IL:|fetch| (READTABLEP IL:COMMONNUMSYNTAX) IL:|of| *READTABLE*)) (IL:* IL:\; "Can't print nice ratios to old read tables") (IL:PRIN1 "|." STREAM) (IL:\\PRINDATUM (LIST (QUOTE /) TOP BOTTOM) STREAM)) (T (IL:* IL:|;;| "If *PRINT-RADIX* is true, need to print radix prefix.  Of course, want it on whole ratio and not components, so we rebind to NIL inside here.") (IF *PRINT-RADIX* (SETQ PR (CONCATENATE (QUOTE STRING) (STRING (CODE-CHAR (IL:|fetch| (READTABLEP IL:HASHMACROCHAR) IL:|of| *READTABLE*))) (CASE *PRINT-BASE* (2 (IL:* IL:\; "Binary") "b") (8 "o") (16 "x") (T (IL:* IL:\; "generalized radix prefix, even for decimal!") (CONCATENATE (QUOTE STRING) (LET* ((X *PRINT-BASE*) (*PRINT-BASE* 10) (*PRINT-RADIX* NIL)) (PRINC-TO-STRING X)) "r")))))) (IL:.SPACECHECK. STREAM (+ 1 (IL:NCHARS TOP) (IL:NCHARS BOTTOM) (IF PR (IL:NCHARS PR) 0))) (LET ((IL:\\THISFILELINELENGTH NIL) (*PRINT-RADIX* NIL)) (DECLARE (IL:SPECVARS IL:\\THISFILELINELENGTH)) (IL:* IL:\; "Turn off linelength check just in case the NCHARS count is off because of radices") (IF PR (IL:\\SOUT PR STREAM)) (IL:\\PRINDATUM TOP STREAM) (IL:\\SOUT "/" STREAM) (IL:\\PRINDATUM BOTTOM STREAM))))))

(DEFUN %BUILD-RATIO (X Y) (IL:* IL:|;;| "%BUILD-RATIO takes two integer arguments and builds the rational number which is their quotient.  ") (LET ((REM (IL:IREMAINDER X Y))) (IF (EQ 0 REM) (IL:IQUOTIENT X Y) (LET ((GCD (%GCD X Y))) (WHEN (NOT (EQ GCD 1)) (SETQ X (IL:IQUOTIENT X GCD)) (SETQ Y (IL:IQUOTIENT Y GCD))) (IF (MINUSP Y) (%MAKE-RATIO (- X) (- Y)) (%MAKE-RATIO X Y))))))

(DEFUN RATIONAL (NUMBER) (IL:* IL:|;;| "Rational produces a rational number for any numeric argument.  Rational assumed that the floating point is completely accurate.  ") (TYPECASE NUMBER (RATIONAL NUMBER) (FLOAT (%RATIONAL-FLOAT NUMBER)) (COMPLEX (%MAKE-COMPLEX (RATIONAL (COMPLEX-REALPART NUMBER)) (RATIONAL (COMPLEX-IMAGPART NUMBER)))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))

(DEFUN RATIONALIZE (NUMBER) (IL:* IL:|;;| "Rationalize does a rational, but it assumes that floats are only accurate to their precision, and generates a good rational aproximation of them.  ") (TYPECASE NUMBER (RATIONAL NUMBER) (FLOAT (%RATIONALIZE-FLOAT NUMBER)) (COMPLEX (%MAKE-COMPLEX (RATIONALIZE (COMPLEX-REALPART NUMBER)) (RATIONALIZE (COMPLEX-IMAGPART NUMBER)))) (T (%NOT-NUMBER-ERROR NUMBER))))

(DEFUN %RATIO-PLUS (NUMERATOR-1 DENOMINATOR-1 NUMERATOR-2 DENOMINATOR-2) (LET ((GCD-D (%GCD DENOMINATOR-1 DENOMINATOR-2))) (IF (EQ GCD-D 1) (%MAKE-RATIO (+ (* NUMERATOR-1 DENOMINATOR-2) (* NUMERATOR-2 DENOMINATOR-1)) (* DENOMINATOR-1 DENOMINATOR-2)) (LET* ((D1/GCD-D (IL:IQUOTIENT DENOMINATOR-1 GCD-D)) (TOP (+ (* NUMERATOR-1 (IL:IQUOTIENT DENOMINATOR-2 GCD-D)) (* NUMERATOR-2 D1/GCD-D))) (GCD-TOP (%GCD TOP GCD-D)) (D2/GCD-TOP DENOMINATOR-2)) (UNLESS (EQ GCD-TOP 1) (SETQ D2/GCD-TOP (IL:IQUOTIENT DENOMINATOR-2 GCD-TOP)) (SETQ TOP (IL:IQUOTIENT TOP GCD-TOP))) (IF (AND (EQ 1 D2/GCD-TOP) (EQ 1 D1/GCD-D)) TOP (%MAKE-RATIO TOP (* D1/GCD-D D2/GCD-TOP)))))))

(DEFUN %RATIO-TIMES (NUMERATOR-1 DENOMINATOR-1 NUMERATOR-2 DENOMINATOR-2) (LET ((GCD-1-2 (%GCD NUMERATOR-1 DENOMINATOR-2)) (GCD-2-1 (%GCD NUMERATOR-2 DENOMINATOR-1))) (UNLESS (EQ GCD-1-2 1) (SETQ NUMERATOR-1 (IL:IQUOTIENT NUMERATOR-1 GCD-1-2)) (SETQ DENOMINATOR-2 (IL:IQUOTIENT DENOMINATOR-2 GCD-1-2))) (UNLESS (EQ GCD-2-1 1) (SETQ NUMERATOR-2 (IL:IQUOTIENT NUMERATOR-2 GCD-2-1)) (SETQ DENOMINATOR-1 (IL:IQUOTIENT DENOMINATOR-1 GCD-2-1)))) (LET ((H (* NUMERATOR-1 NUMERATOR-2)) (K (* DENOMINATOR-1 DENOMINATOR-2))) (IF (EQ K 1) H (IF (MINUSP K) (%MAKE-RATIO (- H) (- K)) (%MAKE-RATIO H K)))))



(IL:* IL:|;;;| "Section 2.1.4 Complex Numbers.")



(DEFSTRUCT (COMPLEX (:CONSTRUCTOR %MAKE-COMPLEX (REALPART IMAGPART)) (:PREDICATE COMPLEXP) (:COPIER NIL) (:PRINT-FUNCTION %COMPLEX-PRINT)) (REALPART :READ-ONLY) (IMAGPART :READ-ONLY))



(IL:* IL:|;;| "So we don't inherit the deftype from defstruct")



(DEFTYPE COMPLEX (&OPTIONAL TYPE) (IF (EQ TYPE (QUOTE *)) (QUOTE (:DATATYPE COMPLEX)) (IL:BQUOTE (AND COMPLEX (SATISFIES (IL:LAMBDA (IL:X) (AND (TYPEP (COMPLEX-REALPART IL:X) (QUOTE (IL:\\\, TYPE))) (TYPEP (COMPLEX-IMAGPART IL:X) (QUOTE (IL:\\\, TYPE))))))))))



(IL:* IL:|;;| "Make Complex  NUMBERP")


(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 

(IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME (QUOTE COMPLEX)) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))
)

(DEFUN COMPLEX (REALPART &OPTIONAL (IMAGPART 0)) (IL:* IL:|;;| "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.   ") (TYPECASE REALPART (RATIONAL (TYPECASE IMAGPART (RATIONAL (IF (EQ 0 IMAGPART) REALPART (%MAKE-COMPLEX REALPART IMAGPART))) (FLOAT (%MAKE-COMPLEX (FLOAT REALPART) IMAGPART)) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR IMAGPART)))) (FLOAT (%MAKE-COMPLEX REALPART (FLOAT IMAGPART))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR REALPART))))

(DEFUN REALPART (NUMBER) (TYPECASE NUMBER (COMPLEX (COMPLEX-REALPART NUMBER)) (NUMBER NUMBER) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))

(DEFUN IMAGPART (NUMBER) (TYPECASE NUMBER (COMPLEX (COMPLEX-IMAGPART NUMBER)) (FLOAT 0.0) (NUMBER 0) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))

(DEFUN CONJUGATE (NUMBER) (TYPECASE NUMBER (COMPLEX (%MAKE-COMPLEX (COMPLEX-REALPART NUMBER) (- (COMPLEX-IMAGPART NUMBER)))) (NUMBER NUMBER) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))

(DEFUN PHASE (NUMBER) (COND ((= NUMBER 0) (IL:* IL:|;;| "The phase of zero is arbitrarily defined to be zero.") 0.0) ((COMPLEXP NUMBER) (ATAN (COMPLEX-IMAGPART NUMBER) (COMPLEX-REALPART NUMBER))) ((MINUSP NUMBER) PI) (T (IL:* IL:|;;| "Page 206 of the silver book: The phase of a positive non-complex number is zero. ... The result is a floating-point number.") 0.0)))

(DEFUN CL:UPGRADED-COMPLEX-PART-TYPE (TYPE) (IL:* IL:\; "Edited 19-Mar-92 15:27 by jrb:") (IF (SUBTYPEP TYPE (QUOTE NUMBER)) (QUOTE NUMBER) (ERROR "Type ~s can't be part of a complex number" TYPE)))

(DEFUN %COMPLEX-PRINT (NUMBER STREAM) (LET ((REALPART (COMPLEX-REALPART NUMBER)) (IMAGPART (COMPLEX-IMAGPART NUMBER))) (IL:.SPACECHECK. STREAM (+ 5 (IL:NCHARS REALPART) (IL:NCHARS IMAGPART))) (IL:\\OUTCHAR STREAM (IL:FETCH (READTABLEP IL:HASHMACROCHAR) IL:OF *READTABLE*)) (IL:\\SOUT "C" STREAM) (IL:\\SOUT "(" STREAM) (IL:\\PRINDATUM REALPART STREAM) (IL:\\SOUT " " STREAM) (IL:\\PRINDATUM IMAGPART STREAM) (IL:\\SOUT ")" STREAM)))

(DEFUN %COMPLEX-+ (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (+ REAL-1 REAL-2) IMAG-2)) ((= IMAG-2 0) (COMPLEX (+ REAL-1 REAL-2) IMAG-1)) (T (COMPLEX (+ REAL-1 REAL-2) (+ IMAG-1 IMAG-2)))))

(DEFUN %COMPLEX-- (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (- REAL-1 REAL-2) (- IMAG-2))) ((= IMAG-2 0) (COMPLEX (- REAL-1 REAL-2) IMAG-1)) (T (COMPLEX (- REAL-1 REAL-2) (- IMAG-1 IMAG-2)))))

(DEFUN %COMPLEX-* (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (* REAL-1 REAL-2) (* REAL-1 IMAG-2))) ((= IMAG-2 0) (COMPLEX (* REAL-1 REAL-2) (* IMAG-1 REAL-2))) (T (COMPLEX (- (* REAL-1 REAL-2) (* IMAG-1 IMAG-2)) (+ (* IMAG-1 REAL-2) (* REAL-1 IMAG-2))))))

(DEFUN %COMPLEX-/ (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= 0 IMAG-1) (LET ((MODULUS (+ (* REAL-2 REAL-2) (* IMAG-2 IMAG-2)))) (COMPLEX (/ (* REAL-1 REAL-2) MODULUS) (/ (- (* REAL-1 IMAG-2)) MODULUS)))) ((= 0 IMAG-2) (COMPLEX (/ REAL-1 REAL-2) (/ IMAG-1 REAL-2))) (T (LET ((MODULUS (+ (* REAL-2 REAL-2) (* IMAG-2 IMAG-2)))) (COMPLEX (/ (+ (* REAL-1 REAL-2) (* IMAG-1 IMAG-2)) MODULUS) (/ (- (* IMAG-1 REAL-2) (* REAL-1 IMAG-2)) MODULUS))))))

(DEFUN %COMPLEX-ABS (Z) (LET ((X (FLOAT (COMPLEX-REALPART Z))) (Y (FLOAT (COMPLEX-IMAGPART Z)))) (DECLARE (TYPE FLOAT X Y)) (IL:* IL:|;;| "Might want to use a BLUE algorithm here") (SQRT (SETQ X (+ (* X X) (* Y Y))))))



(IL:* IL:|;;;| "Datatype predicates")





(IL:* IL:|;;| "cl:integerp is defined in cmlpred (has an optimizer)")





(IL:* IL:|;;| "cl:floatp is defined in cmltypes (has an optimizer). il:floatp is defined on llbasic"
)





(IL:* IL:|;;| "cl:complexp is a defstruct predicate (compiles in line)")





(IL:* IL:|;;| 
"cl:numberp is defined in cmltypes (has an optimizer). il:numberp is defined on llbasic")





(IL:* IL:|;;;| "Section 12.2 Predicates on Numbers (generic).")





(IL:* IL:|;;| 
"cl:zerop  is not shared with il:zerop, although they are equivalent. There is no il;plusp ")



(DEFUN ZEROP (NUMBER) (= 0 NUMBER))

(DEFUN PLUSP (NUMBER) (> NUMBER 0))

(XCL:DEFOPTIMIZER ZEROP (NUMBER) (IL:BQUOTE (= 0 (IL:\\\, NUMBER))))

(XCL:DEFOPTIMIZER PLUSP (NUMBER) (IL:BQUOTE (> (IL:\\\, NUMBER) 0)))



(IL:* IL:|;;| 
"cl:minusp is shared with il:minusp, but must be redefined to work with ratios. Old version resides in llarith"
)



(DEFUN MINUSP (NUMBER) (< NUMBER 0))

(XCL:DEFOPTIMIZER MINUSP (NUMBER) (IL:BQUOTE (< (IL:\\\, NUMBER) 0)))



(IL:* IL:|;;| 
"Both cl:evenp and cl:oddp are shared with il:. The functions are extended by allowing a second optional modulus argument. Another version of il:oddp exists on llarith, but the definition of il:evenp has disappeared"
)



(DEFUN EVENP (INTEGER &OPTIONAL MODULUS) (IF (NULL MODULUS) (EQ (LOGAND INTEGER 1) 0) (ZEROP (MOD INTEGER MODULUS))))

(DEFUN ODDP (INTEGER &OPTIONAL MODULUS) (IF (NULL MODULUS) (EQ (LOGAND INTEGER 1) 1) (NOT (ZEROP (MOD INTEGER MODULUS)))))

(XCL:DEFOPTIMIZER EVENP (INTEGER &OPTIONAL (MODULUS NIL MODULUS-P)) (IF (NULL MODULUS-P) (IL:BQUOTE (EQ (LOGAND (IL:\\\, INTEGER) 1) 0)) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER ODDP (INTEGER &OPTIONAL (MODULUS NIL MODULUS-P)) (IF (NULL MODULUS-P) (IL:BQUOTE (EQ (LOGAND (IL:\\\, INTEGER) 1) 1)) (QUOTE COMPILER:PASS)))



(IL:* IL:|;;;| "Section 12.3 Comparisons on Numbers. (generic)")



(DEFUN %= (X Y) (IL:* IL:|;;| "%= does coercion when checking numbers for equality.  Page 196 of silver book.") (IL:* IL:|;;| "Punt function for opcode =(decimal 255) -- actually the UFN is IL:%=") (IL:\\CALLME (QUOTE =)) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IEQP X Y)) (FLOAT (IL:FEQP X Y)) (RATIO NIL) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT RATIO) (IL:FEQP X Y)) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER NIL) (RATIO (AND (EQL (RATIO-NUMERATOR X) (RATIO-NUMERATOR Y)) (EQL (RATIO-DENOMINATOR X) (RATIO-DENOMINATOR Y)))) (FLOAT (IL:FEQP X Y)) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y (COMPLEX (AND (= (COMPLEX-REALPART X) (COMPLEX-REALPART Y)) (= (COMPLEX-IMAGPART X) (COMPLEX-IMAGPART Y)))) (NUMBER (AND (= Y (COMPLEX-REALPART X)) (= 0 (COMPLEX-IMAGPART X)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))

(DEFMACRO %/= (X Y) (IL:BQUOTE (NOT (%= (IL:\\\, X) (IL:\\\, Y)))))

(DEFUN %> (X Y) (IL:* IL:|;;| "See page 196 of CLtl") (IL:* IL:|;;| "Compiles out to greaterp opcode") (IL:* IL:\; "So we appear as > in a frame backtrace") (IL:\\CALLME (QUOTE >)) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IGREATERP X Y)) (FLOAT (IL:FGREATERP X Y)) (RATIO (IL:IGREATERP (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FGREATERP X Y)) (RATIO (IL:FGREATERP (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (IL:IGREATERP (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (FLOAT (IL:FGREATERP (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (RATIO (IL:IGREATERP (* (RATIO-NUMERATOR X) (RATIO-DENOMINATOR Y)) (* (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR X)))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR X))))

(DEFUN %< (X Y) (%> Y X))

(DEFMACRO %>= (X Y) (IL:BQUOTE (NOT (%< (IL:\\\, X) (IL:\\\, Y)))))

(DEFMACRO %<= (X Y) (IL:BQUOTE (NOT (%> (IL:\\\, X) (IL:\\\, Y)))))

(IL:PUTPROPS %= IL:DOPVAL (2 =))

(IL:PUTPROPS %> IL:DOPVAL (2 IL:GREATERP))

(IL:PUTPROPS %< IL:DOPVAL (2 IL:SWAP IL:GREATERP))



(IL:* IL:\; "For the byte compiler")



(IL:PUTPROPS %> IL:DMACRO (= . IL:GREATERP))

(IL:PUTPROPS %< IL:DMACRO (= . IL:LESSP))

(IL:PUTPROPS %>= IL:DMACRO (= . IL:GEQ))

(IL:PUTPROPS %<= IL:DMACRO (= . IL:LEQ))
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 

(IL:* IL:|;;| "Backward compatibility")

(IL:* IL:\; " il:%= is listed as the punt function for the = opcode")

(IL:MOVD (QUOTE %=) (QUOTE IL:%=))

(IL:* IL:\; "Greaterp is the UFN for the greaterp opcode. Effectively redefines the opcode")

(IL:MOVD (QUOTE %>) (QUOTE IL:GREATERP))

(IL:* IL:\; "Interlisp Greaterp and Lessp are defined in llarith")

(IL:MOVD (QUOTE %<) (QUOTE IL:LESSP))
)



(IL:* IL:|;;| "=, <, >, <=, and >= are shared with il:, but cl:/= is NOT shared (?!)")


(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 

(DEFMACRO %COMPARISON-MACRO (PREDICATE ARGS) (IL:BQUOTE (PROGN (IF (%< (IL:\\\, ARGS) 1) (ERROR (IL:\\\, (CONCATENATE (QUOTE STRING) (SUBSEQ (STRING PREDICATE) 1) " requires at least one argument")))) (LET ((LAST-ARG (IL:ARG (IL:\\\, ARGS) 1)) (I 2) CURRENT-ARG) (IF (OR (NOT (NUMBERP LAST-ARG)) (COMPLEXP LAST-ARG)) (%NOT-NUMBER-ERROR LAST-ARG)) (LOOP (IF (%> I (IL:\\\, ARGS)) (RETURN T)) (SETQ CURRENT-ARG (IL:ARG (IL:\\\, ARGS) I)) (IF (NOT ((IL:\\\, PREDICATE) LAST-ARG CURRENT-ARG)) (RETURN NIL)) (SETQ LAST-ARG CURRENT-ARG) (SETQ I (1+ I)))))))
)
(IL:DEFINEQ

(=

  (il:lambda args
                                       (il:* il:\; "Edited  8-Apr-87 14:40 by jop")

    (if (%< args 1)
        (error "= requires at least one argument"))
    (let ((first-arg (il:arg args 1))
          (i 2))
         (if (not (numberp first-arg))
             (%not-number-error first-arg))
         (loop (if (%> i args)
                   (return t))
               (if (%/= first-arg (il:arg args i))
                   (return nil))
               (setq i (1+ i))))))

(/=

  (il:lambda args
                                       (il:* il:\; "Edited  8-Feb-87 14:01 by jop")

    (if (%< args 1)
        (error "/= requires at least one argument"))
    (let ((i 1)
          current-arg j)
         (loop (if (%> i args)
                   (return t))
               (setq current-arg (il:arg args i))
               (setq j (1+ i))
               (if (null (loop (if (%> j args)
                                   (return t))
                               (if (%= current-arg (il:arg args j))
                                   (return nil))
                               (setq j (1+ j))))
                   (return nil))
               (setq i (1+ i))))))

(<

  (il:lambda args
                                       (il:* il:\; "Edited  8-Feb-87 14:17 by jop")

    (%comparison-macro %< args)))

(>

  (il:lambda args
                                       (il:* il:\; "Edited  8-Feb-87 14:17 by jop")

    (%comparison-macro %> args)))

(<=

  (il:lambda args
                                       (il:* il:\; "Edited  8-Feb-87 14:16 by jop")

    (%comparison-macro %<= args)))

(>=

  (il:lambda args
                                       (il:* il:\; "Edited  8-Feb-87 14:18 by jop")

    (%comparison-macro %>= args)))
)

(DEFUN %COMPARISON-OPTIMIZER (PREDICATE FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (COND ((NULL SECOND-NUMBER) (QUOTE COMPILER:PASS)) ((NULL THIRD-NUMBER) (IL:BQUOTE ((IL:\\\, PREDICATE) (IL:\\\, FIRST-NUMBER) (IL:\\\, SECOND-NUMBER)))) (T (IL:BQUOTE ((IL:OPENLAMBDA (SI::%$$COMPARISON-FIRST-NUMBER SI::%$$COMPARISON-MIDDLE-NUMBER) (AND ((IL:\\\, PREDICATE) SI::%$$COMPARISON-FIRST-NUMBER SI::%$$COMPARISON-MIDDLE-NUMBER) ((IL:\\\, PREDICATE) SI::%$$COMPARISON-MIDDLE-NUMBER (IL:\\\, THIRD-NUMBER)))) (IL:\\\, FIRST-NUMBER) (IL:\\\, SECOND-NUMBER))))))

(XCL:DEFOPTIMIZER = (FIRST-NUMBER &OPTIONAL (SECOND-NUMBER NIL SECOND-NUMBER-P) &REST MORE-NUMBERS) (COND ((NULL SECOND-NUMBER-P) (QUOTE COMPILER:PASS)) ((NULL MORE-NUMBERS) (IL:BQUOTE (%= (IL:\\\, FIRST-NUMBER) (IL:\\\, SECOND-NUMBER)))) (T (SETQ MORE-NUMBERS (CONS SECOND-NUMBER MORE-NUMBERS)) (IL:BQUOTE ((IL:OPENLAMBDA (SI::%$$=FIRST-NUMBER) (AND (IL:\\\,@ (LET ((RESULT NIL) (RESULT-TAIL NIL)) (DOLIST (NUMBER MORE-NUMBERS RESULT) (%LIST-COLLECT RESULT RESULT-TAIL (LIST (IL:BQUOTE (%= SI::%$$=FIRST-NUMBER (IL:\\\, NUMBER)))))))))) (IL:\\\, FIRST-NUMBER))))))

(XCL:DEFOPTIMIZER /= (FIRST-NUMBER &OPTIONAL (SECOND-NUMBER NIL SECOND-NUMBER-P) &REST MORE-NUMBERS) (COND ((NULL SECOND-NUMBER-P) (QUOTE COMPILER:PASS)) ((NULL MORE-NUMBERS) (IL:BQUOTE (%/= (IL:\\\, FIRST-NUMBER) (IL:\\\, SECOND-NUMBER)))) (T (QUOTE COMPILER:PASS))))

(XCL:DEFOPTIMIZER < (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER (QUOTE %<) FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER > (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER (QUOTE %>) FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER <= (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER (QUOTE %<=) FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER >= (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER (QUOTE %>=) FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (QUOTE COMPILER:PASS)))



(IL:* IL:|;;| 
"Note: the related predicates EQL, EQUAL, and EQUALP should be consulted if any of the above change. EQL is on LLNEW (?), EQUAL and EQUALP on CMLTYPES."
)





(IL:* IL:|;;| 
"cl:min and cl:max are shared with il: (defined in llarith). They  are written in terms of GREATERP and hence work on ratios. Note (min) returns #.max.integer , which is an extension on the CLtl spec. We only optimize the case of two args"
)



(XCL:DEFOPTIMIZER MIN (&OPTIONAL (X NIL X-P) (Y NIL Y-P) &REST OTHER-NUMBERS) (IF (AND (NULL OTHER-NUMBERS) X-P Y-P) (IL:BQUOTE ((IL:OPENLAMBDA (SI::%$$MIN-X SI::%$$MIN-Y) (IF (< SI::%$$MIN-X SI::%$$MIN-Y) SI::%$$MIN-X SI::%$$MIN-Y)) (IL:\\\, X) (IL:\\\, Y))) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER MAX (&OPTIONAL (X NIL X-P) (Y NIL Y-P) &REST OTHER-NUMBERS) (IF (AND (NULL OTHER-NUMBERS) X-P Y-P) (IL:BQUOTE ((IL:OPENLAMBDA (SI::%$$MAX-X SI::%$$MAX-Y) (IF (> SI::%$$MAX-X SI::%$$MAX-Y) SI::%$$MAX-X SI::%$$MAX-Y)) (IL:\\\, X) (IL:\\\, Y))) (QUOTE COMPILER:PASS)))



(IL:* IL:|;;;| "Section 12.4 Arithmetic Operations (generic). ")



(DEFUN %+ (X Y) (IL:\\CALLME (QUOTE +)) (IL:* IL:|;;| "Simple case for the sum of two numbers. Is the ufn for the plus2 opcode") (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IPLUS X Y)) (FLOAT (IL:FPLUS X Y)) (RATIO (%RATIO-PLUS X 1 (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-+ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FPLUS X Y)) (RATIO (IL:FPLUS X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-+ X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) Y 1)) (FLOAT (IL:FPLUS (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-+ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))

(DEFUN %- (X Y) (IL:* IL:|;;| "UFN for opcode difference.  ") (IL:\\CALLME (QUOTE -)) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IDIFFERENCE X Y)) (FLOAT (IL:FDIFFERENCE X Y)) (RATIO (%RATIO-PLUS X 1 (- (RATIO-NUMERATOR Y)) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-- X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FDIFFERENCE X Y)) (RATIO (IL:FDIFFERENCE X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-- X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (- Y) 1)) (FLOAT (IL:FDIFFERENCE (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (- (RATIO-NUMERATOR Y)) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-- X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))

(DEFUN %* (X Y) (IL:* IL:|;;| "UFN for opcode times2. ") (IL:\\CALLME (QUOTE *)) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:ITIMES X Y)) (FLOAT (IL:FTIMES X Y)) (RATIO (%RATIO-TIMES X 1 (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-* X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FTIMES X Y)) (RATIO (IL:FTIMES X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-* X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) Y 1)) (FLOAT (IL:FTIMES (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-* X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))

(DEFUN %/ (X Y) (IL:* IL:|;;| "The quotient of two numbers. Has no corresponding opcode.") (IL:\\CALLME (QUOTE /)) (IF (AND (IL:SMALLP X) (IL:SMALLP Y) (EQ 0 (IL:IREMAINDER X Y))) (IL:* IL:|;;| "See if we can do the straight-forward thing") (IL:IQUOTIENT X Y) (IL:* IL:|;;| "More exotic cases") (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IF (OR (EQ X IL:MIN.INTEGER) (EQ X IL:MAX.INTEGER) (EQ Y IL:MIN.INTEGER) (EQ Y IL:MAX.INTEGER)) (IL:IQUOTIENT X Y) (%BUILD-RATIO X Y))) (FLOAT (IL:FQUOTIENT X Y)) (RATIO (%RATIO-TIMES X 1 (RATIO-DENOMINATOR Y) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FQUOTIENT X Y)) (RATIO (IL:FQUOTIENT (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) 1 Y)) (FLOAT (IL:FQUOTIENT (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (RATIO (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-DENOMINATOR Y) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X)))))



(IL:* IL:\; 
"NOTE: %/ cannot compile out to the existinq quotient opcode because it produces ratios rather than truncating"
)



(IL:PUTPROPS %+ IL:DOPVAL (2 IL:PLUS2))

(IL:PUTPROPS %- IL:DOPVAL (2 IL:DIFFERENCE))

(IL:PUTPROPS %* IL:DOPVAL (2 IL:TIMES2))



(IL:* IL:\; "For the byte compiler")



(IL:PUTPROPS %+ IL:DMACRO (= . IL:PLUS))

(IL:PUTPROPS %- IL:DMACRO (= . IL:DIFFERENCE))

(IL:PUTPROPS %* IL:DMACRO (= . IL:TIMES))
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 

(IL:* IL:|;;| "Backward compatibility")

(IL:MOVD (QUOTE %/) (QUOTE IL:%/))

(IL:* IL:|;;| "Redefine UFNs for generic plus, difference, and times. Old UFN defined in llarith.")

(IL:MOVD (QUOTE %+) (QUOTE IL:\\SLOWPLUS2))

(IL:MOVD (QUOTE %-) (QUOTE IL:\\SLOWDIFFERENCE))

(IL:MOVD (QUOTE %*) (QUOTE IL:\\SLOWTIMES2))
)
(IL:DEFINEQ

(+

  (il:lambda args
                                       (il:* il:\; "Edited  8-Apr-87 14:41 by jop")

    (if (eq args 0)
        0
        (let ((accumulator (il:arg args 1))
              (i 2))
             (if (not (numberp accumulator))
                 (%not-number-error accumulator))
             (loop (if (%> i args)
                       (return accumulator))
                   (setq accumulator (%+ accumulator (il:arg args i)))
                   (setq i (1+ i)))))))

(-

  (il:lambda args
                                       (il:* il:\; "Edited  9-Feb-87 20:57 by jop")

    (cond
       ((eq args 0)
        (error "- requires at least one argument"))
       ((eq args 1)
          
          (il:* il:|;;| "Negate the argument")


        (-
 0 (il:arg args 1)))
       (t (let ((accumulator (il:arg args 1))
                (i 2))
               (loop (if (%> i args)
                         (return accumulator))
                     (setq accumulator (%- accumulator (il:arg args i)))
                     (setq i (1+ i))))))))

(*

  (il:lambda args
                                       (il:* il:\; "Edited  8-Apr-87 14:41 by jop")

    (if (eq args 0)
        1
        (let ((accumulator (il:arg args 1))
              (i 2))
             (if (not (numberp accumulator))
                 (%not-number-error accumulator))
             (loop (if (%> i args)
                       (return accumulator))
                   (setq accumulator (%* accumulator (il:arg args i)))
                   (setq i (1+ i)))))))

(/

  (il:lambda args
                                       (il:* il:\; "Edited  8-Feb-87 19:15 by jop")

    (cond
       ((eq args 0)
        (error "/ requires at least one argument"))
       ((eq args 1)
        (%reciprocol (il:arg args 1)))
       (t (let ((accumulator (il:arg args 1))
                (i 2))
               (loop (if (%> i args)
                         (return accumulator))
                     (setq accumulator (%/ accumulator (il:arg args i)))
                     (setq i (1+ i))))))))
)

(DEFUN 1+ (NUMBER) (+ NUMBER 1))

(DEFUN 1- (NUMBER) (- NUMBER 1))

(DEFUN %RECIPROCOL (NUMBER) (IF (FLOATP NUMBER) (IL:FQUOTIENT 1.0 NUMBER) (/ 1 NUMBER)))

(XCL:DEFOPTIMIZER + (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (%+ (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER - (NUMBER &REST NUMBERS) (IF (NULL NUMBERS) (IL:BQUOTE (%- 0 (IL:\\\, NUMBER))) (LET ((FORM NUMBER)) (DOLIST (NUM NUMBERS FORM) (SETQ FORM (IL:BQUOTE (%- (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER * (&REST NUMBERS) (IF (NULL NUMBERS) 1 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (%* (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER / (NUMBER &REST NUMBERS) (IF (NULL NUMBERS) (IL:BQUOTE (%RECIPROCOL (IL:\\\, NUMBER))) (LET ((FORM NUMBER)) (DOLIST (NUM NUMBERS FORM) (SETQ FORM (IL:BQUOTE (%/ (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER 1+ (NUMBER) (IL:BQUOTE (+ (IL:\\\, NUMBER) 1)))

(XCL:DEFOPTIMIZER 1- (NUMBER) (IL:BQUOTE (- (IL:\\\, NUMBER) 1)))



(IL:* IL:\; "For the byte compiler")



(IL:PUTPROPS + IL:DMACRO (IL:ARGS (IL:|if| (IL:GREATERP (IL:LENGTH IL:ARGS) 1) IL:|then| (IL:BQUOTE (IL:PLUS (IL:\\\,@ IL:ARGS))) IL:|else| (QUOTE IL:IGNOREMACRO))))

(IL:PUTPROPS * IL:DMACRO (IL:ARGS (IL:|if| (IL:GREATERP (IL:LENGTH IL:ARGS) 1) IL:|then| (IL:BQUOTE (IL:TIMES (IL:\\\,@ IL:ARGS))) IL:|else| (QUOTE IL:IGNOREMACRO))))



(IL:* IL:|;;| "Redefine Interlisp generic arithmetic to work with ratios")


(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY 

(IL:MOVD (QUOTE +) (QUOTE IL:PLUS))

(IL:* IL:|;;| "Don't need to redefine difference since it is defined in terms of the difference opcode (redefined above)")

(IL:MOVD (QUOTE *) (QUOTE IL:TIMES))

(IL:* IL:|;;| "So Interlisp quotient will do something reasonable with ratios")

(IL:* (IL:MOVD (QUOTE IL:NEW-QUOTIENT) (QUOTE IL:QUOTIENT)))

(IL:* IL:|;;| "because QUOTIENT is already defined in LLARITH to do something useful with ratios. AR 8062.")
)



(IL:* IL:|;;| "INCF and DECF implemented by CMLSETF.")



(DEFUN %GCD (X Y) (IL:* IL:|;;| "%GCD -- Gcd of two integers, no type checking. ") (SETQ X (%ABS X)) (SETQ Y (%ABS Y)) (COND ((EQ X 0) Y) ((EQ Y 0) X) ((OR (EQL 1 Y) (EQL 1 X)) 1) (T (LET ((K (IL:* IL:\; "Factor out powers of two") (DO ((K 0 (1+ K))) ((OR (ODDP X) (ODDP Y)) K) (SETQ X (ASH X -1)) (SETQ Y (ASH Y -1))))) (DO ((J (IF (ODDP X) (- Y) (ASH X -1)) (- X Y))) ((EQ J 0)) (LOOP (IF (ODDP J) (RETURN NIL)) (SETQ J (ASH J -1))) (IF (PLUSP J) (SETQ X J) (SETQ Y (- J)))) (ASH X K)))))

(DEFUN %LCM (X Y) (COND ((EQ X 1) Y) ((EQ Y 1) X) ((OR (EQ X 0) (EQ Y 0)) 0) (T (SETQ X (%ABS X)) (SETQ Y (%ABS Y)) (LET ((GCD (%GCD X Y))) (IF (EQ GCD 1) (* X Y) (* (IL:IQUOTIENT X GCD) Y))))))
(IL:DEFINEQ

(gcd

  (il:lambda args
                                       (il:* il:\; "Edited 10-Feb-87 11:14 by jop")

          
          (il:* il:|;;| "GCD -- gcd of an arbitrary number of integers.  Since the probability is >.6 that the GCD of two numbers is 1, it is worth to time to check for GCD = 1 and quit if so.  ")


    (cond
       ((eq args 0)
        0)
       ((eq args 1)
        (%abs (il:arg args 1)))
       (t (let ((result (%gcd (il:arg args 1)
                              (il:arg args 2)))
                (i 3))
               (loop (if (or (>
 i args)
                             (eq result 1))
                         (return result))
                     (setq result (%gcd result (il:arg args i)))
                     (setq i (1+ i))))))))

(LCM

(IL:LAMBDA ARGS (IL:* IL:\; "Edited 25-Feb-87 12:20 by jop") (IL:* IL:|;;| "LCM -- least common multiple.  At least one argument is required.    ") (COND ((EQ ARGS 0) 1) ((EQ ARGS 1) (%ABS (IL:ARG ARGS 1))) (T (LET ((RESULT (%LCM (IL:ARG ARGS 1) (IL:ARG ARGS 2))) (I 3)) (LOOP (IF (OR (> I ARGS) (EQ RESULT 0)) (RETURN RESULT)) (SETQ RESULT (%LCM RESULT (IL:ARG ARGS I))) (SETQ I (1+ I)))))))
)
)



(IL:* IL:|;;| "Optimizers for Interlisp functions, so that they compile open with the PavCompiler.")





(IL:* IL:|;;| "optimizer of IL:minus")



(XCL:DEFOPTIMIZER IL:MINUS (IL:X) (IL:BQUOTE (- 0 (IL:\\\, IL:X))))

(XCL:DEFOPTIMIZER IL:PLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:PLUS2 (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER IL:IPLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (COND ((CDR NUMBERS) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:IPLUS2 (IL:\\\, FORM) (IL:\\\, NUM)))))) (T (IL:BQUOTE (IL:IPLUS2 (IL:\\\, FORM) 0)))))))

(XCL:DEFOPTIMIZER IL:FPLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:FPLUS2 (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER IL:TIMES (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:TIMES2 (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER IL:ITIMES (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:ITIMES2 (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER IL:FTIMES (&REST NUMBERS) (IF (NULL NUMBERS) 1.0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM (IL:BQUOTE (IL:FTIMES2 (IL:\\\, FORM) (IL:\\\, NUM))))))))

(XCL:DEFOPTIMIZER IL:RSH (IL:VALUE IL:SHIFT-AMOUNT) (IL:BQUOTE (IL:LSH (IL:\\\, IL:VALUE) (IL:IMINUS (IL:\\\, IL:SHIFT-AMOUNT)))))

(IL:PUTPROPS IL:PLUS2 IL:DOPVAL (2 IL:PLUS2))

(IL:PUTPROPS IL:IPLUS2 IL:DOPVAL (2 IL:IPLUS2))

(IL:PUTPROPS IL:FPLUS2 IL:DOPVAL (2 IL:FPLUS2))

(IL:PUTPROPS IL:TIMES2 IL:DOPVAL (2 IL:TIMES2))

(IL:PUTPROPS IL:ITIMES2 IL:DOPVAL (2 IL:ITIMES2))

(IL:PUTPROPS IL:FTIMES2 IL:DOPVAL (2 IL:FTIMES2))



(IL:* IL:|;;;| 
"Section 12.5 Irrational and Transcendental functions. Most of these will be found on cmlfloat.")



(DEFUN ISQRT (INTEGER) (IL:* IL:|;;| "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. Initial bounds guarantee that lg (sqrt (n)) = lg (n) /2 iterations suffice.") (IF (NOT (AND (INTEGERP INTEGER) (>= INTEGER 0))) (ERROR (QUOTE XCL:TYPE-MISMATCH) :EXPECTED-TYPE (QUOTE (INTEGER 0)) :NAME INTEGER :VALUE INTEGER :MESSAGE "a nonnegative integer")) (LET* ((ILENGTH (INTEGER-LENGTH INTEGER)) (LOW (ASH 1 (ASH (1- ILENGTH) -1))) (HIGH (+ LOW (ASH LOW (IF (ODDP ILENGTH) -1 0))))) (DO ((MID (ASH (+ LOW HIGH) -1) (ASH (+ LOW HIGH) -1))) ((<= (1- HIGH) LOW) LOW) (IF (<= (* MID MID) INTEGER) (SETQ LOW MID) (SETQ HIGH MID)))))



(IL:* IL:|;;| "Abs is shared with il: abs ia also defined in llarith.")



(DEFUN ABS (NUMBER) (TYPECASE NUMBER (INTEGER (IF (< NUMBER 0) (- 0 NUMBER) NUMBER)) (FLOAT (IF (< NUMBER 0.0) (- 0.0 NUMBER) NUMBER)) (RATIO (IF (< (RATIO-NUMERATOR NUMBER) 0) (%MAKE-RATIO (- 0 (RATIO-NUMERATOR NUMBER)) (RATIO-DENOMINATOR NUMBER)) NUMBER)) (COMPLEX (%COMPLEX-ABS NUMBER)) (T (%NOT-NUMBER-ERROR NUMBER))))

(DEFMACRO %ABS (INTEGER) (IL:* IL:|;;| "Integer version of abs") (IL:BQUOTE ((IL:OPENLAMBDA (X) (IF (< X 0) (- 0 X) X)) (IL:\\\, INTEGER))))

(DEFUN SIGNUM (NUMBER) (IL:* IL:|;;| "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER)).") (IF (ZEROP NUMBER) NUMBER (TYPECASE NUMBER (RATIONAL (IF (PLUSP NUMBER) 1 -1)) (FLOAT (IF (PLUSP NUMBER) 1.0 -1.0)) (COMPLEX (/ NUMBER (ABS NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))))

(DEFMACRO %SIGNUM (INTEGER) (IL:* IL:|;;| "Integer version of signum") (IL:BQUOTE ((IL:OPENLAMBDA (X) (COND ((EQ X 0) 0) ((PLUSP X) 1) (T -1))) (IL:\\\, INTEGER))))



(IL:* IL:|;;;| "Section 12.6 Type Conversions and Component Extractions on Numbers.")





(IL:* IL:|;;| "Float implemented in cmlfloat  ")


(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 

(IL:FILESLOAD IL:UNBOXEDOPS)
)



(IL:* IL:\; "These should be exported from xcl")



(DEFUN XCL::STRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 ") (IF (NULL DIVISOR) (TYPECASE NUMBER (FLOAT (IL:* IL:|;;| "Could be (IL:FIX NUMBER), but this is slightly faster") (IL:\\FIXP.FROM.FLOATP NUMBER)) (RATIO (IL:IQUOTIENT (RATIO-NUMERATOR NUMBER) (RATIO-DENOMINATOR NUMBER))) (INTEGER NUMBER) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR NUMBER))) (TYPECASE DIVISOR (INTEGER (IL:IQUOTIENT NUMBER DIVISOR)) (FLOAT (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR))) (DECLARE (TYPE FLOAT FX FY)) (IL:UFIX (IL:FQUOTIENT FX FY)))) (RATIO (XCL::STRUNCATE (/ NUMBER DIVISOR))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR DIVISOR)))))

(DEFUN XCL::SFLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns the greatest integer not greater than number, or number/divisor. ") (IF (NULL DIVISOR) (LET ((RESULT (XCL::STRUNCATE NUMBER))) (COND ((= RESULT NUMBER) RESULT) ((< NUMBER 0) (1- RESULT)) (T RESULT))) (LET ((RESULT (XCL::STRUNCATE NUMBER DIVISOR))) (IF (= (REM NUMBER DIVISOR) 0) RESULT (IF (< NUMBER 0) (IF (< DIVISOR 0) RESULT (1- RESULT)) (IF (< DIVISOR 0) (1- RESULT) RESULT))))))

(DEFUN XCL::SCEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns the least integer not less than number, or number/divisor. ") (IF (NULL DIVISOR) (LET ((RESULT (XCL::STRUNCATE NUMBER))) (COND ((= RESULT NUMBER) RESULT) ((< NUMBER 0) RESULT) (T (1+ RESULT)))) (LET ((RESULT (XCL::STRUNCATE NUMBER DIVISOR))) (IF (= (REM NUMBER DIVISOR) 0) RESULT (IF (< NUMBER 0) (IF (< DIVISOR 0) (1+ RESULT) RESULT) (IF (< DIVISOR 0) RESULT (1+ RESULT)))))))

(DEFUN XCL::SROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 ") (IF (NULL DIVISOR) (IL:FIXR NUMBER) (IF (OR (FLOATP NUMBER) (FLOATP DIVISOR)) (IL:FIXR (IL:FQUOTIENT NUMBER DIVISOR)) (IL:FIXR (/ NUMBER DIVISOR)))))

(XCL:DEFOPTIMIZER XCL::STRUNCATE (NUMBER &OPTIONAL DIVISOR) (IF (INTEGERP DIVISOR) (IL:BQUOTE (IL:IQUOTIENT (IL:\\\, NUMBER) (IL:\\\, DIVISOR))) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER XCL::SROUND (NUMBER &OPTIONAL (DIVISOR NIL DIVISOR-P)) (IF (NULL DIVISOR-P) (IL:BQUOTE (IL:FIXR (IL:\\\, NUMBER))) (QUOTE COMPILER:PASS)))



(IL:* IL:\; "Round is shared with il: (?!)")


(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 

(DEFMACRO %INTEGER-COERCE-MACRO (SINGLE-VALUE-FN NUMBER DIVISOR &OPTIONAL FLOAT-RESULT) (IL:BQUOTE (LET* ((RESULT (IF (NULL (IL:\\\, DIVISOR)) ((IL:\\\, SINGLE-VALUE-FN) (IL:\\\, NUMBER)) ((IL:\\\, SINGLE-VALUE-FN) (IL:\\\, NUMBER) (IL:\\\, DIVISOR)))) (REMAINDER (IF (NULL (IL:\\\, DIVISOR)) (- (IL:\\\, NUMBER) RESULT) (- (IL:\\\, NUMBER) (* (IL:\\\, DIVISOR) RESULT))))) (VALUES (IL:\\\, (IF FLOAT-RESULT (QUOTE (FLOAT RESULT)) (QUOTE RESULT))) REMAINDER))))
)

(DEFUN TRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::STRUNCATE NUMBER DIVISOR))

(DEFUN FLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward - infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SFLOOR NUMBER DIVISOR))

(DEFUN CEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward + infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SCEILING NUMBER DIVISOR))

(DEFUN ROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward nearest integer. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SROUND NUMBER DIVISOR))

(DEFUN %INTEGER-COERCE-OPTIMIZER (SINGLE-VALUE-FN NUMBER DIVISOR CONTEXT &OPTIONAL FLOAT-RESULT) (IF (EQ 1 (COMPILER:CONTEXT-VALUES-USED CONTEXT)) (LET ((FORM (IL:BQUOTE ((IL:\\\, SINGLE-VALUE-FN) (IL:\\\, NUMBER) (IL:\\\,@ (IF DIVISOR (LIST DIVISOR))))))) (IF FLOAT-RESULT (IL:BQUOTE (FLOAT (IL:\\\, FORM))) FORM)) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER TRUNCATE (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::STRUNCATE) NUMBER DIVISOR CONTEXT))

(XCL:DEFOPTIMIZER FLOOR (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SFLOOR) NUMBER DIVISOR CONTEXT))

(XCL:DEFOPTIMIZER CEILING (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SCEILING) NUMBER DIVISOR CONTEXT))

(XCL:DEFOPTIMIZER ROUND (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SROUND) NUMBER DIVISOR CONTEXT))

(DEFUN FTRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::STRUNCATE NUMBER DIVISOR T))

(DEFUN FFLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Like floor, but returns the first result as a float ") (%INTEGER-COERCE-MACRO XCL::SFLOOR NUMBER DIVISOR T))

(DEFUN FCEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward + infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SCEILING NUMBER DIVISOR T))

(DEFUN FROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward nearest integer. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SROUND NUMBER DIVISOR T))

(XCL:DEFOPTIMIZER FTRUNCATE (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::STRUNCATE) NUMBER DIVISOR CONTEXT T))

(XCL:DEFOPTIMIZER FFLOOR (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SFLOOR) NUMBER DIVISOR CONTEXT T))

(XCL:DEFOPTIMIZER FCEILING (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SCEILING) NUMBER DIVISOR CONTEXT T))

(XCL:DEFOPTIMIZER FROUND (NUMBER &OPTIONAL DIVISOR CL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER (QUOTE XCL::SROUND) NUMBER DIVISOR CONTEXT T))

(DEFUN MOD (NUMBER DIVISOR) (IL:* IL:|;;| "Returns second result of FLOOR.") (IF (OR (FLOATP NUMBER) (FLOATP DIVISOR)) (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR)) REM) (DECLARE (TYPE FLOAT FX FY REM)) (SETQ REM (- FX (* (FLOAT (IL:UFIX (IL:FQUOTIENT FX FY))) FY))) (IF (IL:UFEQP REM 0.0) 0.0 (IF (IF (IL:UFGREATERP 0.0 FY) (IL:UFGREATERP FX 0.0) (IL:UFGREATERP 0.0 FX)) (SETQ REM (+ REM FY)))) REM) (LET ((REM (REM NUMBER DIVISOR))) (IF (AND (NOT (ZEROP REM)) (IF (MINUSP DIVISOR) (PLUSP NUMBER) (MINUSP NUMBER))) (+ REM DIVISOR) REM))))

(DEFUN REM (NUMBER DIVISOR) (IL:* IL:|;;| "Returns the second value of truncate") (COND ((AND (INTEGERP NUMBER) (INTEGERP DIVISOR)) (IL:IREMAINDER NUMBER DIVISOR)) ((OR (FLOATP NUMBER) (FLOATP DIVISOR)) (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR))) (DECLARE (TYPE FLOAT FX FY)) (SETQ FX (- FX (* (FLOAT (IL:UFIX (IL:FQUOTIENT FX FY))) FY))))) (T (- NUMBER (* DIVISOR (XCL::STRUNCATE NUMBER DIVISOR))))))



(IL:* IL:|;;| 
"Should IL:remainder be equivalent to cl:rem?. Thereis no IL:mod in the IRM, although it has a macro which makes it equivalent to imod."
)





(IL:* IL:|;;| "See cmlfloat for ffloor and friends, decode-float and friends")





(IL:* IL:|;;;| "Section 12.7 Logical Operations on Numbers.")





(IL:* IL:|;;| "LOGXOR and LOGAND are shared with IL. (definitions in llarith)")



(DEFUN %LOGICAL-OPTIMIZER (BINARY-LOGICAL-FN IDENTITY FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) (COND ((NULL FIRST-INTEGER) IDENTITY) ((NULL SECOND-INTEGER) FIRST-INTEGER) ((NULL MORE-INTEGERS) (IL:BQUOTE ((IL:\\\, BINARY-LOGICAL-FN) (IL:\\\, FIRST-INTEGER) (IL:\\\, SECOND-INTEGER)))) (T (LET ((FORM (IL:BQUOTE ((IL:\\\, BINARY-LOGICAL-FN) (IL:\\\, FIRST-INTEGER) (IL:\\\, SECOND-INTEGER))))) (DOLIST (INTEGER MORE-INTEGERS FORM) (SETQ FORM (IL:BQUOTE ((IL:\\\, BINARY-LOGICAL-FN) (IL:\\\, FORM) (IL:\\\, INTEGER)))))))))

(XCL:DEFOPTIMIZER LOGXOR (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (IF (AND COMPILER::*NEW-COMPILER-IS-EXPANDING* MORE-INTEGERS) (%LOGICAL-OPTIMIZER (QUOTE LOGXOR) 0 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER LOGAND (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (IF (AND COMPILER::*NEW-COMPILER-IS-EXPANDING* MORE-INTEGERS) (%LOGICAL-OPTIMIZER (QUOTE LOGAND) -1 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) (QUOTE COMPILER:PASS)))

(DEFUN %LOGIOR (X Y) (IL:LOGOR X Y))

(DEFMACRO %LOGEQV (X Y) (IL:BQUOTE (LOGNOT (LOGXOR (IL:\\\, X) (IL:\\\, Y)))))

(IL:PUTPROPS %LOGIOR IL:DOPVAL (2 IL:LOGOR2))



(IL:* IL:\; "for the byte compiler")



(IL:PUTPROPS %LOGIOR IL:DMACRO (= . IL:LOGOR))
(IL:DEFINEQ

(logior

  (il:lambda args
                                       (il:* il:\; "Edited 11-Feb-87 11:22 by jop")

          
          (il:* il:|;;| "Cannot be called interpreted. This defn relies on fact that the compiler turns class to %LOGIOR calls into  a sequence of opcodes")


    (cond
       ((eq args 0)
        0)
       ((eq args 1)
        (il:arg args 1))
       ((eq args 2)
        (%logior (il:arg args 1)
               (il:arg args 2)))
       (t (let ((result (%logior (il:arg args 1)
                               (il:arg args 2)))
                (i 3))
               (loop (if (%> i args)
                         (return result))
                     (setq result (%logior result (il:arg args i)))
                     (setq i (1+ i))))))))

(logeqv

  (il:lambda args
                                       (il:* il:\; "Edited 11-Feb-87 13:20 by jop")

          
          (il:* il:|;;| "Cannot be called interpreted. This defn relies on fact that the compiler turns class to %LOGIOR calls into  a sequence of opcodes")


    (cond
       ((eq args 0)
        -1)
       ((eq args 1)
        (il:arg args 1))
       ((eq args 2)
        (%logeqv (il:arg args 1)
               (il:arg args 2)))
       (t (let ((result (%logeqv (il:arg args 1)
                               (il:arg args 2)))
                (i 3))
               (loop (if (%> i args)
                         (return result))
                     (setq result (%logeqv result (il:arg args i)))
                     (setq i (1+ i))))))))
)

(XCL:DEFOPTIMIZER LOGIOR (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (%LOGICAL-OPTIMIZER (QUOTE %LOGIOR) 0 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS))

(XCL:DEFOPTIMIZER LOGEQV (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (%LOGICAL-OPTIMIZER (QUOTE %LOGEQV) -1 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS))

(DEFUN LOGNAND (INTEGER1 INTEGER2) (LOGNOT (LOGAND INTEGER1 INTEGER2)))

(DEFUN LOGNOR (INTEGER1 INTEGER2) (LOGNOT (LOGIOR INTEGER1 INTEGER2)))

(DEFUN LOGANDC1 (INTEGER1 INTEGER2) (LOGAND (LOGNOT INTEGER1) INTEGER2))

(DEFUN LOGANDC2 (INTEGER1 INTEGER2) (LOGAND INTEGER1 (LOGNOT INTEGER2)))

(DEFUN LOGORC1 (INTEGER1 INTEGER2) (LOGIOR (LOGNOT INTEGER1) INTEGER2))

(DEFUN LOGORC2 (INTEGER1 INTEGER2) (LOGIOR INTEGER1 (LOGNOT INTEGER2)))

(XCL:DEFOPTIMIZER LOGNAND (INTEGER1 INTEGER2) (IL:BQUOTE (LOGNOT (LOGAND (IL:\\\, INTEGER1) (IL:\\\, INTEGER2)))))

(XCL:DEFOPTIMIZER LOGNOR (INTEGER1 INTEGER2) (IL:BQUOTE (LOGNOT (LOGIOR (IL:\\\, INTEGER1) (IL:\\\, INTEGER2)))))

(XCL:DEFOPTIMIZER LOGANDC1 (INTEGER1 INTEGER2) (IL:BQUOTE (LOGAND (LOGNOT (IL:\\\, INTEGER1)) (IL:\\\, INTEGER2))))

(XCL:DEFOPTIMIZER LOGANDC2 (INTEGER1 INTEGER2) (IL:BQUOTE (LOGAND (IL:\\\, INTEGER1) (LOGNOT (IL:\\\, INTEGER2)))))

(XCL:DEFOPTIMIZER LOGORC1 (INTEGER1 INTEGER2) (IL:BQUOTE (LOGIOR (LOGNOT (IL:\\\, INTEGER1)) (IL:\\\, INTEGER2))))

(XCL:DEFOPTIMIZER LOGORC2 (INTEGER1 INTEGER2) (IL:BQUOTE (LOGIOR (IL:\\\, INTEGER1) (LOGNOT (IL:\\\, INTEGER2)))))

(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)

(DEFUN BOOLE (OP INTEGER1 INTEGER2) (COND ((EQ OP BOOLE-CLR) 0) ((EQ OP BOOLE-SET) -1) ((EQ OP BOOLE-1) INTEGER1) ((EQ OP BOOLE-2) INTEGER2) ((EQ OP BOOLE-C1) (LOGNOT INTEGER1)) ((EQ OP BOOLE-C2) (LOGNOT INTEGER2)) ((EQ OP BOOLE-AND) (LOGAND INTEGER1 INTEGER2)) ((EQ OP BOOLE-IOR) (LOGIOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-XOR) (LOGXOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-EQV) (LOGEQV INTEGER1 INTEGER2)) ((EQ OP BOOLE-NAND) (LOGNAND INTEGER1 INTEGER2)) ((EQ OP BOOLE-NOR) (LOGNOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-ANDC1) (LOGANDC1 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ANDC2) (LOGANDC2 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ORC1) (LOGORC1 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ORC2) (LOGORC2 INTEGER1 INTEGER2)) (T (ERROR "Not a valid op: ~s" OP))))



(IL:* IL:|;;| "Lognot is shared with IL.(in addarith) ")



(DEFUN LOGTEST (INTEGER1 INTEGER2) (NOT (EQ 0 (LOGAND INTEGER1 INTEGER2))))

(XCL:DEFINLINE LOGBITP (INDEX INTEGER) (EQ 1 (LOGAND 1 (ASH INTEGER (- INDEX)))))

(XCL:DEFOPTIMIZER LOGTEST (INTEGER1 INTEGER2) (IL:BQUOTE (NOT (EQ 0 (LOGAND (IL:\\\, INTEGER1) (IL:\\\, INTEGER2))))))

(DEFUN ASH (INTEGER COUNT) (IL:LSH INTEGER COUNT))

(IL:PUTPROPS ASH IL:DOPVAL (2 IL:LSH))



(IL:* IL:\; "For the byte compiler")



(IL:PUTPROPS ASH IL:DMACRO (= . IL:LSH))

(DEFUN LOGCOUNT (INTEGER) (IL:* IL:|;;| "Logcount returns the number of bits that are the complement of the sign in the integer argument x.  ") (IL:* IL:|;;| "If INTEGER is negative, then the number of 0 bits is returned, otherwise number of 1 bits is returned.  ") (IF (MINUSP INTEGER) (SETQ INTEGER (LOGNOT INTEGER))) (IF (NOT (IL:TYPENAMEP INTEGER (QUOTE BIGNUM))) (%LOGCOUNT INTEGER) (%BIGNUM-LOGCOUNT INTEGER)))

(DEFUN %LOGCOUNT (POSITIVE-INTEGER) (IL:* IL:|;;| "Returns number of 1 bits in nonnegative integer N.  ") (LET ((CNT 0)) (IL:* IL:\; "This loop uses a LOGAND trick to reduce the number of iterations.  ") (LOOP (IF (EQ 0 POSITIVE-INTEGER) (RETURN CNT)) (IL:* IL:\; "Change rightmost 1 bit of N to a 0 bit.  ") (SETQ CNT (1+ CNT)) (SETQ POSITIVE-INTEGER (LOGAND POSITIVE-INTEGER (1- POSITIVE-INTEGER))))))
(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 

(IL:FILESLOAD (IL:LOADCOMP) IL:LLBIGNUM)
)



(IL:* IL:\; "Should be in llbignum")



(DEFUN %BIGNUM-LOGCOUNT (BIGNUM) (LET ((ELEMENTS (IL:|fetch| (BIGNUM IL:ELEMENTS) IL:|of| BIGNUM)) (CNT 0)) (DOLIST (ELEMENT ELEMENTS CNT) (SETQ CNT (+ CNT (%LOGCOUNT ELEMENT))))))

(DEFUN INTEGER-LENGTH (INTEGER) (COND ((< INTEGER 0) (SETQ INTEGER (- -1 INTEGER)))) (IL:* IL:|;;| "This algorithm is basicly a binary search") (MACROLET ((BITS-OR-LESS-P (INTEGER N) (IL:BQUOTE (< (IL:\\\, INTEGER) (IL:\\\, (ASH 1 N)))))) (IF (BITS-OR-LESS-P INTEGER 16) (COND ((BITS-OR-LESS-P INTEGER 8) (COND ((BITS-OR-LESS-P INTEGER 4) (COND ((BITS-OR-LESS-P INTEGER 2) (IF (BITS-OR-LESS-P INTEGER 1) INTEGER 2)) ((BITS-OR-LESS-P INTEGER 3) 3) (T 4))) ((BITS-OR-LESS-P INTEGER 6) (IF (BITS-OR-LESS-P INTEGER 5) 5 6)) ((BITS-OR-LESS-P INTEGER 7) 7) (T 8))) ((BITS-OR-LESS-P INTEGER 12) (COND ((BITS-OR-LESS-P INTEGER 10) (IF (BITS-OR-LESS-P INTEGER 9) 9 10)) ((BITS-OR-LESS-P INTEGER 11) 11) (T 12))) ((BITS-OR-LESS-P INTEGER 14) (IF (BITS-OR-LESS-P INTEGER 13) 13 14)) ((BITS-OR-LESS-P INTEGER 15) 15) (T 16)) (+ 16 (INTEGER-LENGTH (ASH INTEGER -16))))))



(IL:* IL:|;;| "OPTIMIZERS FOR IL:LLSH AND IL:LRSH")



(DEFUN %LLSH8 (X) (IL:LLSH X 8))

(DEFUN %LLSH1 (X) (IL:LLSH X 1))

(DEFUN %LRSH8 (X) (IL:LRSH X 8))

(DEFUN %LRSH1 (X) (IL:LRSH X 1))

(IL:PUTPROPS %LLSH8 IL:DOPVAL (1 IL:LLSH8))

(IL:PUTPROPS %LLSH1 IL:DOPVAL (1 IL:LLSH1))

(IL:PUTPROPS %LRSH8 IL:DOPVAL (1 IL:LRSH8))

(IL:PUTPROPS %LRSH1 IL:DOPVAL (1 IL:LRSH1))

(XCL:DEFOPTIMIZER IL:LLSH (X N) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (LET ((M (AND (CONSTANTP N) (EVAL N)))) (IF (TYPEP M (QUOTE (INTEGER 0))) (LET ((FORM X)) (LOOP (IF (< M 8) (RETURN NIL)) (SETQ FORM (IL:BQUOTE (%LLSH8 (IL:\\\, FORM)))) (DECF M 8)) (LOOP (IF (<= M 0) (RETURN NIL)) (SETQ FORM (IL:BQUOTE (%LLSH1 (IL:\\\, FORM)))) (DECF M 1)) FORM) (QUOTE COMPILER:PASS))) (QUOTE COMPILER:PASS)))

(XCL:DEFOPTIMIZER IL:LRSH (X N) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (LET ((M (AND (CONSTANTP N) (EVAL N)))) (IF (TYPEP M (QUOTE (INTEGER 0))) (LET ((FORM X)) (LOOP (IF (< M 8) (RETURN NIL)) (SETQ FORM (IL:BQUOTE (%LRSH8 (IL:\\\, FORM)))) (DECF M 8)) (LOOP (IF (<= M 0) (RETURN NIL)) (SETQ FORM (IL:BQUOTE (%LRSH1 (IL:\\\, FORM)))) (DECF M 1)) FORM) (QUOTE COMPILER:PASS))) (QUOTE COMPILER:PASS)))



(IL:* IL:|;;;| "Section 12.8 Byte Manipulations Functions.")



(DEFUN BYTE (SIZE POSITION) (IF (OR (< SIZE 0) (< POSITION 0)) (ERROR "Not a valid bytespec: ~s ~s" SIZE POSITION) (IF (AND (< SIZE 256) (< POSITION 256)) (+ (ASH SIZE 8) POSITION) (CONS SIZE POSITION))))

(XCL:DEFINLINE BYTE-SIZE (BYTESPEC) (IF (TYPEP BYTESPEC (QUOTE FIXNUM)) (ASH BYTESPEC -8) (CAR BYTESPEC)))

(XCL:DEFINLINE BYTE-POSITION (BYTESPEC) (IF (TYPEP BYTESPEC (QUOTE FIXNUM)) (LOGAND BYTESPEC 255) (CDR BYTESPEC)))



(IL:* IL:|;;| 
"Byte doesn't need an optimizer since the side-effects data-base will do constant folding, but the byte-compiler can profit from an optimizer"
)



(DEFUN OPTIMIZE-BYTE (SIZE POSITION) (IF (AND (TYPEP SIZE (QUOTE (INTEGER 0 255))) (TYPEP POSITION (QUOTE (INTEGER 0 255)))) (+ (ASH SIZE 8) POSITION) (QUOTE COMPILER:PASS)))

(IL:PUTPROPS BYTE IL:DMACRO (IL:ARGS (OPTIMIZE-BYTE (CAR IL:ARGS) (CADR IL:ARGS))))
(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 

(DEFMACRO %MAKE-BYTE-MASK-1 (SIZE POSITION) (IF (EQ POSITION 0) (IL:BQUOTE (1- (ASH 1 (IL:\\\, SIZE)))) (IL:BQUOTE (ASH (1- (ASH 1 (IL:\\\, SIZE))) (IL:\\\, POSITION)))))

(DEFMACRO %MAKE-BYTE-MASK-0 (SIZE POSITION) (IL:BQUOTE (LOGNOT (%MAKE-BYTE-MASK-1 (IL:\\\, SIZE) (IL:\\\, POSITION)))))
)

(DEFUN LDB (BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGAND (ASH INTEGER (- POSITION)) (%MAKE-BYTE-MASK-1 SIZE 0))))

(DEFUN DPB (NEWBYTE BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGIOR (ASH (LOGAND NEWBYTE (%MAKE-BYTE-MASK-1 SIZE 0)) POSITION) (LOGAND INTEGER (%MAKE-BYTE-MASK-0 SIZE POSITION)))))

(DEFUN MASK-FIELD (BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGAND INTEGER (%MAKE-BYTE-MASK-1 SIZE POSITION))))

(DEFUN DEPOSIT-FIELD (NEWBYTE BYTESPEC INTEGER) (LET* ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC)) (MASK (%MAKE-BYTE-MASK-1 SIZE POSITION))) (LOGIOR (LOGAND NEWBYTE MASK) (LOGAND INTEGER (LOGNOT MASK)))))

(DEFUN %CONSTANT-BYTESPEC-P (BYTESPEC) (COND ((TYPEP BYTESPEC (QUOTE FIXNUM)) BYTESPEC) ((AND (CONSP BYTESPEC) (EQ (CAR BYTESPEC) (QUOTE BYTE)) (INTEGERP (CADR BYTESPEC)) (INTEGERP (CADDR BYTESPEC))) (EVAL BYTESPEC)) (T NIL)))

(XCL:DEFOPTIMIZER LDB (BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) (IF (ZEROP POSITION) (IL:BQUOTE (LOGAND (IL:\\\, INTEGER) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE 0)))) (IL:BQUOTE (LOGAND (ASH (IL:\\\, INTEGER) (IL:\\\, (- POSITION))) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE 0)))))) (QUOTE COMPILER:PASS))))

(XCL:DEFOPTIMIZER DPB (NEWBYTE BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) (IF (ZEROP POSITION) (IL:BQUOTE (LOGIOR (LOGAND (IL:\\\, NEWBYTE) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE 0))) (LOGAND (IL:\\\, INTEGER) (IL:\\\, (%MAKE-BYTE-MASK-0 SIZE 0))))) (IL:BQUOTE (LOGIOR (ASH (LOGAND (IL:\\\, NEWBYTE) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE 0))) (IL:\\\, POSITION)) (LOGAND (IL:\\\, INTEGER) (IL:\\\, (%MAKE-BYTE-MASK-0 SIZE POSITION))))))) (QUOTE COMPILER:PASS))))

(XCL:DEFOPTIMIZER MASK-FIELD (BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) (IL:BQUOTE (LOGAND (IL:\\\, INTEGER) (IL:\\\, (%MAKE-BYTE-MASK-1 SIZE POSITION))))) (QUOTE COMPILER:PASS))))

(XCL:DEFOPTIMIZER DEPOSIT-FIELD (NEWBYTE BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET* ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE)) (MASK (%MAKE-BYTE-MASK-1 SIZE POSITION))) (IL:BQUOTE (LOGIOR (LOGAND (IL:\\\, NEWBYTE) (IL:\\\, MASK)) (LOGAND (IL:\\\, INTEGER) (IL:\\\, (LOGNOT MASK)))))) (QUOTE COMPILER:PASS))))

(DEFUN LDB-TEST (BYTESPEC INTEGER) (NOT (EQ 0 (LDB BYTESPEC INTEGER))))

(XCL:DEFOPTIMIZER LDB-TEST (BYTESPEC INTEGER) (IL:BQUOTE (NOT (EQ 0 (LDB (IL:\\\, BYTESPEC) (IL:\\\, INTEGER))))))
(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY

(IL:LOCALVARS . T)
)
)

(IL:PUTPROPS IL:CMLARITH IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))

(IL:PUTPROPS IL:CMLARITH IL:FILETYPE COMPILE-FILE)
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 

(IL:ADDTOVAR IL:NLAMA)

(IL:ADDTOVAR IL:NLAML)

(IL:ADDTOVAR IL:LAMA LOGEQV LOGIOR LCM GCD / * - + >= <= > < /= =)
)
(IL:PUTPROPS IL:CMLARITH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1992)
)
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (25091 26923 (= 25104 . 25610) (/= 25612 . 26313) (< 26315 . 26464) (> 26466 . 26615)
 (<= 26617 . 26768) (>= 26770 . 26921)) (36716 38838 (+ 36729 . 37225) (- 37227 . 37811) (* 37813 . 
38309) (/ 38311 . 38836)) (41628 42826 (GCD 41641 . 42419) (LCM 42421 . 42824)) (55724 57294 (LOGIOR 
55737 . 56513) (LOGEQV 56515 . 57292)))))
IL:STOP