(FILECREATED " 4-Feb-86 16:10:09" {ERIS}<FISCHER>CML>CMLARITH.;2 12207
changes to: (FNS BOOLE)
(VARS CMLARITHCOMS)
previous date: " 5-Sep-85 02:58:56" {ERIS}<LISP>KOTO>LIBRARY>CMLARITH.;1)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLARITHCOMS)
(RPAQQ CMLARITHCOMS [(RECORDS RATIO COMPLEX)
(FNS PLUSP)
(* MINUSP ODDP EVENP are close enough)
(FNS = /= < > <= >=)
(MACROS = /= < > <= >=)
(FNS %%=)
(MACROS =)
(* MAX and MIN are OK)
(P (MOVD (QUOTE PLUS)
(QUOTE +))
(MOVD (QUOTE TIMES)
(QUOTE CL:*)))
(PROP DMACRO + CL:*)
(FNS - / %%/)
(PROP DMACRO - /)
(FNS 1+ 1-)
(MACROS 1+ 1-)
(FNS CONJUGATE SIGNUM RATIONALP LOGEQV LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2 BOOLE
LOGTEST LOGBITP BYTE-SIZE BYTE-POSITION LDB-TEST MASK-FIELD DEPOSIT-FIELD)
(P (MOVD (QUOTE INTEGERLENGTH)
(QUOTE INTEGER-LENGTH)))
(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])
)
(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]
)
(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]
)
(* MAX and MIN are OK)
(MOVD (QUOTE PLUS)
(QUOTE +))
(MOVD (QUOTE TIMES)
(QUOTE CL:*))
(PUTPROPS + DMACRO (= . PLUS))
(PUTPROPS CL:* DMACRO (= . TIMES))
(DEFINEQ
(-
(CL:LAMBDA (NUMBER &REST NUMBERS)
(IF (NULL NUMBERS)
THEN (DIFFERENCE 0 NUMBER)
ELSE (LET ((RESULT NUMBER))
(FOR X IN NUMBERS DO (SETQ RESULT (DIFFERENCE RESULT X)))
RESULT))))
(/
[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)
(if (EVENP X Y)
then (QUOTIENT X Y)
else (ERROR "Ratios not implemented"])
)
(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])
(PUTPROPS / DMACRO [DEFMACRO (NUMBER &REST NUMBERS)
(IF (NULL NUMBERS)
THEN
(BQUOTE (%%/ 0 (\, 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)))
)
(DEFINEQ
(CONJUGATE
[LAMBDA (NUMBER)
(IF (TYPE? COMPLEX NUMBER)
THEN (CREATE COMPLEX
REALPART ← (FETCH REALPART NUMBER)
IMAGPART ← (FETCH IMAGPART NUMBER))
ELSE NUMBER])
(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])
(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) (* raf " 4-Feb-86 16:09")
(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))
(ERROR "Element 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) (* kbr: "31-Aug-85 21:26")
(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)))
)
(MOVD (QUOTE INTEGERLENGTH)
(QUOTE INTEGER-LENGTH))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA LOGEQV / - >= <= > < /= =)
)
(PUTPROPS CMLARITH COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1521 1595 (PLUSP 1531 . 1593)) (1643 2904 (= 1653 . 1818) (/= 1820 . 2042) (< 2044 .
2257) (> 2259 . 2478) (<= 2480 . 2690) (>= 2692 . 2902)) (5681 5985 (%%= 5691 . 5983)) (6428 7107 (-
6438 . 6692) (/ 6694 . 6969) (%%/ 6971 . 7105)) (7674 7776 (1+ 7684 . 7725) (1- 7727 . 7774)) (7893
11908 (CONJUGATE 7903 . 8116) (SIGNUM 8118 . 8480) (RATIONALP 8482 . 8578) (LOGEQV 8580 . 8853) (
LOGNAND 8855 . 9005) (LOGNOR 9007 . 9155) (LOGANDC1 9157 . 9315) (LOGANDC2 9317 . 9468) (LOGORC1 9470
. 9625) (LOGORC2 9627 . 9776) (BOOLE 9778 . 10530) (LOGTEST 10532 . 10697) (LOGBITP 10699 . 10854) (
BYTE-SIZE 10856 . 11021) (BYTE-POSITION 11023 . 11196) (LDB-TEST 11198 . 11367) (MASK-FIELD 11369 .
11634) (DEPOSIT-FIELD 11636 . 11906)))))
STOP