(FILECREATED " 3-Dec-85 16:25:44" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;10 15466
changes to: (VARS CMLARITHCOMS)
previous date: "11-Nov-85 16:11:17" {ERIS}<LISPCORE>LIBRARY>CMLARITH.;9)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLARITHCOMS)
(RPAQQ CMLARITHCOMS [(RECORDS RATIO COMPLEX)
(FNS PLUSP)
(* MINUSP ODDP EVENP are close enough)
(COMS (FNS = /= < > <= >=)
(FNS %%=)
(MACROS = /= < > <= >=))
(* MAX and MIN are OK)
(COMS (FNS - + CL:* / %%/)
(MACROS - + CL:* /))
(COMS (FNS 1+ 1-)
(MACROS 1+ 1-))
(CONSTANTS PI (MOST-POSITIVE-FIXNUM MAX.SMALLP)
(MOST-NEGATIVE-FIXNUM MIN.SMALLP))
(FNS CONJUGATE PHASE SIGNUM CL:SIN CL:COS CL:TAN ASIN ACOS RATIONALP LOGEQV LOGNAND LOGNOR
LOGANDC1 LOGANDC2 LOGORC1 LOGORC2 BOOLE LOGTEST LOGBITP BYTE-SIZE BYTE-POSITION LDB-TEST
MASK-FIELD DEPOSIT-FIELD)
(CONSTANTS 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)
(P (MOVD (QUOTE INTEGERLENGTH)
(QUOTE INTEGER-LENGTH))
(MOVD (QUOTE LSH)
(QUOTE ASH))
(MOVD (QUOTE LOGOR)
(QUOTE LOGIOR)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA LOGEQV / - >= <= > < /= =])
[DECLARE: EVAL@COMPILE
(DATATYPE RATIO (NUMERATOR DENOMINATOR))
(DEFSTRUCT (COMPLEX (:CONC-NAME NIL)
(:CONSTRUCTOR COMPLEX)
(:PREDICATE COMPLEXP))
REALPART IMAGPART)
]
(/DECLAREDATATYPE (QUOTE RATIO)
(QUOTE (POINTER POINTER))
(QUOTE ((RATIO 0 POINTER)
(RATIO 2 POINTER)))
(QUOTE 4))
(/DECLAREDATATYPE (QUOTE COMPLEX)
(QUOTE (POINTER POINTER))
(QUOTE ((COMPLEX 0 POINTER)
(COMPLEX 2 POINTER)))
(QUOTE 4))
(DEFINEQ
(PLUSP
(CL:LAMBDA (NUMBER)
(GREATERP NUMBER 0)))
)
(* MINUSP ODDP EVENP are close enough)
(DEFINEQ
(=
(CL:LAMBDA (NUMBER &REST MORE-NUMBERS) (* lmm "16-Jul-85 16:51")
(for X in MORE-NUMBERS always (%%= NUMBER X))))
(/=
[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 "16-Jul-85 17:03")
(for X on MORE-NUMBERS while (CDR X) always (LESSP (CAR X)
(CADR X])
(>
[CL:LAMBDA (&REST MORE-NUMBERS) (* lmm "16-Jul-85 17:04")
(for X on MORE-NUMBERS while (CDR X) always (GREATERP (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 "16-Jul-85 17:19")
(for X on MORE-NUMBERS while (CDR X) always (GEQ (CAR X)
(CADR X])
)
(DEFINEQ
(%%=
[LAMBDA (X Y) (* lmm "16-Jul-85 17:01")
(* sort of like EQP)
(if (AND (FIXP X)
(FIXP Y))
then (IEQP X Y)
else (FEQP X Y])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS = DMACRO (DEFMACRO (N &REST NS)
(COND ((CDR NS)
(BQUOTE ([OPENLAMBDA (N)
(AND (= N (\, (CAR NS)))
(= N (\,@ (CDR NS]
, N)))
(T (BQUOTE (%%= (\, N)
(\, (CAR NS]
[PUTPROPS
/= DMACRO
(DEFMACRO
(N &REST NS)
(COND
[NS
(IF
(CDR NS)
THEN
[LET [(VARS (FOR X IN (CONS N NS)
COLLECT
(LIST (GENSYM (QUOTE /=))
X]
(BQUOTE ([OPENLAMBDA
(\, (MAPCAR VARS (QUOTE CAR)))
(AND (\,@ (for X on VARS join
(for Y on (CDR VARS)
collect
(BQUOTE (NOT (= (\, (CAAR X))
(\, (CAAR Y]
(\,@ (MAPCAR VARS (QUOTE CADR]
ELSE
(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 (GEQ (\, (CAAR X))
(\, (CAADR X]
(\,@ (MAPCAR VARS (QUOTE CADR]
(T (BQUOTE (GEQ (\, N)
(\, (CAR NS]
)
(* MAX and MIN are OK)
(DEFINEQ
(-
(CL:LAMBDA (NUMBER &REST NUMBERS) (* raf "11-Nov-85 16:01")
(if (NULL NUMBERS)
then (DIFFERENCE 0 NUMBER)
else (LET ((RESULT NUMBER))
(for X in NUMBERS do (SETQ RESULT (DIFFERENCE RESULT X)))
RESULT))))
(+
(CL:LAMBDA (&REST NUMBERS)
(if (NULL NUMBERS)
then 0
else (APPLY (FUNCTION PLUS)
NUMBERS))))
(CL:*
(CL:LAMBDA (&REST NUMBERS)
(if (NULL NUMBERS)
then 1
else (APPLY (FUNCTION TIMES)
NUMBERS))))
(/
[CL:LAMBDA (NUMBER &REST NUMBERS) (* lmm " 5-Sep-85 02:56")
(if (NULL NUMBERS)
then (%%/ 1 NUMBER)
else (for X in NUMBERS do (SETQ NUMBER (%%/ NUMBER X)) finally (RETURN NUMBER])
(%%/
[LAMBDA (X Y) (* raf "11-Nov-85 16:10")
(if (AND (FIXP X)
(FIXP Y)
(ODDP X Y))
then (ERROR "Ratios not implemented")
else (QUOTIENT X Y])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS - DMACRO (DEFMACRO (NUMBER &REST NUMBERS)
(if (NULL NUMBERS)
then
(BQUOTE (DIFFERENCE 0 (\, NUMBER)))
else
(for X in NUMBERS do [SETQ NUMBER (BQUOTE (DIFFERENCE (\, NUMBER)
(\, X]
finally
(RETURN NUMBER]
[DEFMACRO + (&REST NUMBERS)
(if (NULL NUMBERS)
then 0 else (BQUOTE (PLUS (\., NUMBERS]
[DEFMACRO CL:* (&REST NUMBERS)
(if (NULL NUMBERS)
then 1 else (BQUOTE (TIMES (\., NUMBERS]
[PUTPROPS / DMACRO (DEFMACRO (NUMBER &REST NUMBERS)
(if (NULL NUMBERS)
then
(BQUOTE (%%/ 1 (\, NUMBER)))
else
(for X in NUMBERS do [SETQ NUMBER (BQUOTE (%%/ (\, NUMBER)
(\, X]
finally
(RETURN NUMBER]
)
(DEFINEQ
(1+
[LAMBDA (X)
(PLUS X 1])
(1-
[LAMBDA (X)
(DIFFERENCE X 1])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS 1+ DMACRO ((X)
(PLUS X 1)))
(PUTPROPS 1- DMACRO ((X)
(DIFFERENCE X 1)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ PI 3.141593)
(RPAQ MOST-POSITIVE-FIXNUM MAX.SMALLP)
(RPAQ MOST-NEGATIVE-FIXNUM MIN.SMALLP)
(CONSTANTS PI (MOST-POSITIVE-FIXNUM MAX.SMALLP)
(MOST-NEGATIVE-FIXNUM MIN.SMALLP))
)
(DEFINEQ
(CONJUGATE
[LAMBDA (NUMBER)
(IF (TYPE? COMPLEX NUMBER)
THEN (CREATE COMPLEX
REALPART ← (FETCH REALPART NUMBER)
IMAGPART ← (FETCH IMAGPART NUMBER))
ELSE NUMBER])
(PHASE
(CL:LAMBDA (NUMBER)
"Returns the angle part of the polar representation of a complex number.
For non-complex numbers, this is 0."
(COND
((COMPLEXP NUMBER)
(CL:ATAN (REALPART NUMBER)
(IMAGPART NUMBER)))
(T 0))))
(SIGNUM
[CL:LAMBDA (NUMBER)
"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])
(CL:SIN
(CL:LAMBDA (RADIANS) (SIN RADIANS T)))
(CL:COS
(CL:LAMBDA (RADIANS) (COS RADIANS T)))
(CL:TAN
(CL:LAMBDA (RADIANS) (TAN RADIANS T)))
(ASIN
(CL:LAMBDA (NUMBER) (ARCSIN NUMBER T)))
(ACOS
(CL:LAMBDA (NUMBER) (ARCCOS NUMBER T)))
(RATIONALP
[LAMBDA (NUMBER)
(OR (INTEGERP NUMBER)
(TYPE? RATIO NUMBER])
(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))))
(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))))
(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)))
(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-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)))
(DEPOSIT-FIELD
(CL:LAMBDA (NEWBYTE BYTESPEC INTEGER) (* kbr: "31-Aug-85 21:23")
(DEPOSITBYTE NEWBYTE (fetch (BYTESPEC BYTESPEC.POSITION) of BYTESPEC)
(fetch (BYTESPEC BYTESPEC.SIZE) of BYTESPEC)
INTEGER)))
)
(DECLARE: EVAL@COMPILE
(RPAQQ BOOLE-CLR 0)
(RPAQQ BOOLE-SET 1)
(RPAQQ BOOLE-1 2)
(RPAQQ BOOLE-2 3)
(RPAQQ BOOLE-C1 4)
(RPAQQ BOOLE-C2 5)
(RPAQQ BOOLE-AND 6)
(RPAQQ BOOLE-IOR 7)
(RPAQQ BOOLE-XOR 8)
(RPAQQ BOOLE-EQV 9)
(RPAQQ BOOLE-NAND 10)
(RPAQQ BOOLE-NOR 11)
(RPAQQ BOOLE-ANDC1 12)
(RPAQQ BOOLE-ANDC2 13)
(RPAQQ BOOLE-ORC1 14)
(RPAQQ BOOLE-ORC2 15)
(CONSTANTS 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)
)
(MOVD (QUOTE INTEGERLENGTH)
(QUOTE INTEGER-LENGTH))
(MOVD (QUOTE LSH)
(QUOTE ASH))
(MOVD (QUOTE LOGOR)
(QUOTE LOGIOR))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA LOGEQV / - >= <= > < /= =)
)
(PRETTYCOMPRINT CMLARITHCOMS)
(RPAQQ CMLARITHCOMS [(RECORDS RATIO COMPLEX)
(FNS PLUSP)
(* MINUSP ODDP EVENP are close enough)
(COMS (FNS = /= < > <= >=)
(FNS %%=)
(MACROS = /= < > <= >=))
(* MAX and MIN are OK)
(COMS (FNS - + CL:* / %%/)
(MACROS - + CL:* /))
(COMS (FNS 1+ 1-)
(MACROS 1+ 1-))
(CONSTANTS PI (MOST-POSITIVE-FIXNUM MAX.SMALLP)
(MOST-NEGATIVE-FIXNUM MIN.SMALLP))
(FNS CONJUGATE PHASE SIGNUM CL:SIN CL:COS CL:TAN ASIN ACOS RATIONALP LOGEQV LOGNAND LOGNOR
LOGANDC1 LOGANDC2 LOGORC1 LOGORC2 BOOLE LOGTEST LOGBITP BYTE-SIZE BYTE-POSITION LDB-TEST
MASK-FIELD DEPOSIT-FIELD)
(CONSTANTS 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)
(P (MOVD (QUOTE INTEGERLENGTH)
(QUOTE INTEGER-LENGTH))
(MOVD (QUOTE LSH)
(QUOTE ASH))
(MOVD (QUOTE LOGOR)
(QUOTE LOGIOR)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA LOGEQV / CL:* + - >= <= > < /= =])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA LOGEQV / CL:* + - >= <= > < /= =)
)
(PUTPROPS CMLARITH COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1844 1918 (PLUSP 1854 . 1916)) (1966 3231 (= 1976 . 2141) (/= 2143 . 2368) (< 2370 .
2585) (> 2587 . 2801) (<= 2803 . 3015) (>= 3017 . 3229)) (3232 3539 (%%= 3242 . 3537)) (6347 7493 (-
6357 . 6666) (+ 6668 . 6812) (CL:* 6814 . 6962) (/ 6964 . 7239) (%%/ 7241 . 7491)) (8255 8357 (1+ 8265
. 8306) (1- 8308 . 8355)) (8701 13204 (CONJUGATE 8711 . 8930) (PHASE 8932 . 9198) (SIGNUM 9200 . 9562
) (CL:SIN 9564 . 9614) (CL:COS 9616 . 9666) (CL:TAN 9668 . 9718) (ASIN 9720 . 9769) (ACOS 9771 . 9820)
(RATIONALP 9822 . 9916) (LOGEQV 9918 . 10191) (LOGNAND 10193 . 10343) (LOGNOR 10345 . 10493) (
LOGANDC1 10495 . 10651) (LOGANDC2 10653 . 10804) (LOGORC1 10806 . 10959) (LOGORC2 10961 . 11110) (
BOOLE 11112 . 11824) (LOGTEST 11826 . 11994) (LOGBITP 11996 . 12149) (BYTE-SIZE 12151 . 12316) (
BYTE-POSITION 12318 . 12490) (LDB-TEST 12492 . 12664) (MASK-FIELD 12666 . 12934) (DEPOSIT-FIELD 12936
. 13202)))))
STOP