(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