(FILECREATED "29-May-86 17:56:54" {ERIS}<LISPCORE>EVAL>ADDARITH.;1
 37309  

      changes to:  (OPTIMIZERS ROT-INLINE)
                   (VARS ADDARITHCOMS)

      previous date: "29-Jan-86 15:35:12" {ERIS}<LISPCORE>SOURCES>ADDARITH.;15)


(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT ADDARITHCOMS)

(RPAQQ ADDARITHCOMS
 [(LOCALVARS . T)
                     (COMS (* Rational operations and useful constants)
                           (FNS \RTIMES2 \RATIONALIZE \RPLUS2 \RMINUS CREATERATIONAL 
                                RATIONALTOINTEGER)
                           (RECORDS RATIONAL))
                     (* OK)
                     (MACROS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT)
                     (* "BYTE hacking functions")
                     (RECORDS BYTESPEC)
                     (FNS LOADBYTE DEPOSITBYTE)
                     (MACROS LOADBYTE DEPOSITBYTE)
                     (FNS IMODLESSP IMODPLUS IMODDIFFERENCE)
                     (MACROS IMODPLUS IMODDIFFERENCE IMOD)
                     (FNS ROT)
                     (OPTIMIZERS ROT-INLINE)
                     (MACROS .ROT.)
                     (* NOT OK YET)
                     (MACROS LDB DPB BYTE BYTESIZE BYTEPOSITION)
                     (FNS \LDBEXPANDER \DPBEXPANDER)
                     (COMS (* "Primitive Functions for extracting fields as integers")
                           (MACROS \XLOADBYTEWORD)
                           (FNS \PUTBASEBITS)
                           (* "Primitive functions, especially needed for CommonLisp array package.")
                           (DECLARE: DONTCOPY (MACROS .HIHALFWORDLO. .HIHALFWORDHI. .LOHALFWORDLO. 
                                                     .LOHALFWORDHI.)
                                  (EXPORT (MACROS \GETBASENIBBLE \PUTBASENIBBLE \GETBASEBIT 
                                                 \PUTBASEBIT)))
                           (FNS \GETBASENIBBLE \PUTBASENIBBLE \GETBASEBIT \PUTBASEBIT))
                     (COMS (* 
          "Beginning of rewrite of some LLARITH things, modularly using the macros of 
	   this file")
                           (DECLARE: DONTCOPY (EXPORT (CONSTANTS MASK0WORD1'S MASK1WORD0'S 
                                                             MASKWORD1'S MASKHALFWORD1'S 
                                                             BITSPERHALFWORD)
                                                     (MACROS EQZEROP)
                                                     (MACROS \MOVETOBOX .XUNBOX. .XLLSH. .XLLSH1. 
                                                            .XLRSH. .ADD.2WORD.INTEGERS. 
                                                            .SUB.2WORD.INTEGERS. .32BITMUL.)
                                                     (MACROS .SUMSMALLMOD. .DIFFERENCESMALLMOD.))
                                  (MACROS .ADD.2WORD.INTEGERS. .SUB.2WORD.INTEGERS. .32BITMUL.])
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)



(* Rational operations and useful constants)


(DEFINEQ

(\RTIMES2

  [LAMBDA (R1 R2)                                            (* lmm "14-Apr-85 19:46")

                                                             (* Rational multiply)

    (if
 (
FLOATP
 R1)
	then
 (
SETQ
 R1 (
MAKERATIONAL
 R1)))
    (if
 (
FLOATP
 R2)
	then
 (
SETQ
 R2 (
MAKERATIONAL
 R2)))
    (if
 (
FIXP
 R1)
	then
 [if
 (
FIXP
 R2)
		 then
 (
ITIMES
 R1 R2)
	       else
 (if
 (
EQUAL
 R1 (fetch
 DENOMINATOR of
 R2))
			then
 (fetch
 NUMERATOR of
 R2)
		      else
 (\RATIONALIZE
 (
ITIMES
 R1 (fetch
 NUMERATOR of
 R2))
					 (fetch
 DENOMINATOR of
 R2]
      elseif
 (
FIXP
 R2)
	then
 (if
 (
EQUAL
 R2 (fetch
 DENOMINATOR of
 R1))
		 then
 (fetch
 NUMERATOR of
 R1)
	       else
 (\RATIONALIZE
 (
TIMES
 R2 (fetch
 NUMERATOR of
 R1))
				  (fetch
 DENOMINATOR of
 R1)))
      elseif
 (
EQUAL
 (fetch
 NUMERATOR of
 R1)
		    (fetch
 DENOMINATOR of
 R2))
	then
 (\RATIONALIZE
 (fetch
 NUMERATOR of
 R2)
			   (fetch
 DENOMINATOR of
 R1))
      elseif
 (
EQUAL
 (fetch
 DENOMINATOR of
 R1)
		    (fetch
 NUMERATOR of
 R2))
	then
 (\RATIONALIZE
 (fetch
 NUMERATOR of
 R1)
			   (fetch
 DENOMINATOR of
 R2))
      else
 (\RATIONALIZE
 (
ITIMES
 (fetch
 NUMERATOR of
 R1)
				 (fetch
 NUMERATOR of
 R2))
			 (
ITIMES
 (fetch
 DENOMINATOR of
 R1)
				 (fetch
 DENOMINATOR of
 R2])

(\RATIONALIZE

  [LAMBDA (NUM DEN)                                          (* lmm "14-Apr-85 20:19")

    (LET ((
GCD
 (
GCD
 NUM DEN)))
      (if
 (
EQUAL
 DEN GCD)
	  then
 (
IQUOTIENT
 NUM GCD)
	else
 (create
 RATIONAL
		     NUMERATOR _(
IQUOTIENT
 NUM GCD)
		     DENOMINATOR _(
IQUOTIENT
 DEN GCD])

(\RPLUS2

  [LAMBDA (R1 R2)                                            (* lmm "14-Apr-85 19:42")

                                                             (* Rational multiply)

    (IF
 (
FLOATP
 R1)
	THEN
 (
SETQ
 R1 (
MAKERATIONAL
 R1)))
    (IF
 (
FLOATP
 R2)
	THEN
 (
SETQ
 R2 (
MAKERATIONAL
 R2)))
    (if
 (
FIXP
 R1)
	then
 (if
 (
FIXP
 R2)
		 then
 (
IPLUS
 R1 R2)
	       else
 (\RATIONALIZE
 (
IPLUS
 (fetch
 NUMERATOR of
 R2)
					 (
ITIMES
 R1 (fetch
 DENOMINATOR of
 R2)))
				  (fetch
 DENOMINATOR of
 R2)))
      elseif
 (
FIXP
 R2)
	then
 (\RATIONALIZE
 (
IPLUS
 (fetch
 NUMERATOR of
 R1)
				  (
ITIMES
 R2 (fetch
 DENOMINATOR of
 R1)))
			   (fetch
 DENOMINATOR of
 R1))
      elseif
 (
EQUAL
 (fetch
 DENOMINATOR of
 R1)
		    (fetch
 DENOMINATOR of
 R2))
	then
 (\RATIONALIZE
 (
IPLUS
 (fetch
 NUMERATOR of
 R1)
				  (fetch
 NUMERATOR of
 R2))
			   (fetch
 DENOMINATOR of
 R2))
      else
 (\RATIONALIZE
 (
IPLUS
 (
ITIMES
 (fetch
 DENOMINATOR of
 R1)
					(fetch
 NUMERATOR of
 R2))
				(
ITIMES
 (fetch
 NUMERATOR of
 R1)
					(fetch
 DENOMINATOR of
 R2)))
			 (
ITIMES
 (fetch
 DENOMINATOR of
 R1)
				 (fetch
 DENOMINATOR of
 R2])

(\RMINUS

  (LAMBDA (X)                                                (* JonL " 4-Jan-85 16:08")

    (if
 (type?
 RATIONAL X)
	then
 (create
 RATIONAL
		     NUMERATOR _(
MINUS
 (fetch
 (RATIONAL NUMERATOR) of
 X))
		     DENOMINATOR _(fetch
 (RATIONAL NUMERATOR) of
 X))
      else
 (
MINUS
 X))))

(CREATERATIONAL

  [LAMBDA (NUMERATOR DENOMINATOR)                            (* jds "10-Jan-85 15:40")

                                                             (* Creates a normalized rational)

    (
PROG
 ((PNUM NUMERATOR)
	   (PDEN DENOMINATOR)
	   GCF NEGFLG)

          (* * Convert to positive format first, since this will minimize consing in GCD and keep the IQUOTIENT in ucode 

	  (where possible))



          (if
 (
ILESSP
 PNUM 0)
	      then
 (
SETQ
 PNUM (
IMINUS
 PNUM))
		   (if
 (
ILESSP
 PDEN 0)
		       then
 (
SETQ
 PDEN (
IMINUS
 PDEN))
		     else
 (
SETQ
 NEGFLG T))
	    else
 (if
 (
ILESSP
 PDEN 0)
		     then
 (
SETQ
 PDEN (
IMINUS
 PDEN))
			  (
SETQ
 NEGFLG T)))
          (
SETQ
 GCF (
GCD
 PNUM PDEN))                         (* Note that the GCD will always be positive)

          (
SETQ
 PNUM (
IQUOTIENT
 PNUM GCF))                   (* Reduce both numerator and denominator by the GCD)

          (
SETQ
 PDEN (
IQUOTIENT
 PDEN GCF))
          (
RETURN
 (
CONS
 (if
 NEGFLG
			    then
 (
IMINUS
 PNUM)
			  else
 PNUM)
			PDEN])

(RATIONALTOINTEGER

  (LAMBDA (RAT)                                              (* JonL " 4-Jan-85 15:59")

    (
FIXR
 (
FQUOTIENT
 (fetch
 (RATIONAL NUMERATOR) of
 RAT)
		     (fetch
 (RATIONAL DENOMINATOR) of
 RAT)))))
)
[DECLARE: EVAL@COMPILE 

(RECORD RATIONAL
 (NUMERATOR . DENOMINATOR)
                 [TYPE? (AND (LISTP DATUM)
                             (FIXP (CAR DATUM))
                             (FIXP (CDR DATUM]
                 (CREATE (CREATERATIONAL NUMERATOR DENOMINATOR)))
]



(* OK)


(DECLARE: EVAL@COMPILE 
(PUTPROPS MASK.1'S MACRO (OPENLAMBDA (POSITION SIZE)
                                (LSH (SUB1 (LSH 1 SIZE))
                                     POSITION)))
[PUTPROPS MASK.0'S MACRO (OPENLAMBDA (POSITION SIZE)
                                (LOGNOT (MASK.1'S POSITION SIZE]
[PUTPROPS BITTEST MACRO ((N MASK)
                         (NEQ 0 (LOGAND N MASK]
(PUTPROPS BITSET MACRO (= . LOGOR))
[PUTPROPS BITCLEAR MACRO ((X MASK)
                          (LOGAND X (LOGNOT MASK]
(PUTPROPS LOGNOT MACRO ((N)
                        (LOGXOR -1 N)))
)



(* "BYTE hacking functions")


[DECLARE: EVAL@COMPILE 

(TYPERECORD BYTESPEC
 (BYTESPEC.SIZE BYTESPEC.POSITION))
]
(DEFINEQ

(LOADBYTE

  [LAMBDA (N POS SIZE)                                       (* lmm "12-Apr-85 14:35")

    (\MACRO.MX (LOADBYTE
 N POS SIZE])

(DEPOSITBYTE

  [LAMBDA (N POS SIZE VAL)                                   (* lmm "12-Apr-85 14:36")

    (\MACRO.MX (DEPOSITBYTE
 N POS SIZE VAL])
)
(DECLARE: EVAL@COMPILE 
[PUTPROPS LOADBYTE MACRO ((N POS SIZE)
                          (LOGAND (RSH N POS)
                                 (MASK.1'S 0 SIZE]
[PUTPROPS DEPOSITBYTE MACRO (OPENLAMBDA (N POS SIZE VAL)
                                   (LOGOR (BITCLEAR N (MASK.1'S POS SIZE))
                                          (LSH (LOGAND VAL (MASK.1'S 0 SIZE))
                                               POS]
)
(DEFINEQ

(IMODLESSP

  [LAMBDA (X Y MODULUS)                                      (* lmm "12-Apr-85 12:43")

    (
ILESSP
 (IMODDIFFERENCE
 Y X MODULUS)
	    (FOLDHI MODULUS 2])

(IMODPLUS

  [LAMBDA (X Y MODULUS)                                      (* lmm "12-Apr-85 12:47")

                                                             (* tune for more efficiency later)

    (\MACRO.MX (IMODPLUS
 X Y MODULUS])

(IMODDIFFERENCE

  [LAMBDA (X Y MODULUS)                                      (* lmm "12-Apr-85 12:48")

    (\MACRO.MX (IMODDIFFERENCE
 X Y MODULUS])
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS IMODPLUS MACRO ((X Y MODULUS)
                          (IMOD (IPLUS X Y)
                                MODULUS)))
(PUTPROPS IMODDIFFERENCE MACRO ((X Y MODULUS)
                                (IMOD (IDIFFERENCE X Y)
                                      MODULUS)))
[PUTPROPS IMOD MACRO (L (PROG [(N (CONSTANTEXPRESSIONP (CADR L]
                              (if (NULL N)
                                  then
                                  (RETURN (QUOTE IGNOREMACRO)))
                              (SETQ N (CAR N))
                              (RETURN (COND ((NOT (POWEROFTWOP N))
                                             (QUOTE IGNOREMACRO))
                                            (T (LIST (QUOTE LOGAND)
                                                     (CAR L)
                                                     (SUB1 N]
)
(DEFINEQ

(ROT

  [LAMBDA (X N FIELDSIZE)                                    (* lmm "12-Apr-85 14:12")


          (* Normalize N, the shift factor, into the half-open interval of 0 to FIELDSIZE and transform a negative N 

	  (rotating rightwards) into a positive form.)



    (LET* ((N (
IMOD
 N FIELDSIZE))
       (N.B (
IDIFFERENCE
 FIELDSIZE N)))
      (DEPOSITBYTE
 (LOADBYTE
 X N.B N)
		   N N.B X])
)
(DEFOPTIMIZER ROT
 ROT-INLINE (X N FIELDSIZE)
                        (if (AND (SETQ N (CONSTANTEXPRESSIONP N))
                                 (SETQ FIELDSIZE (CONSTANTEXPRESSIONP FIELDSIZE))
                                 (FIXP (CAR N))
                                 (FIXP (CAR FIELDSIZE)))
                            then                             (* fieldsize and N are constants)

                            (BQUOTE (.ROT. , X , (IMOD (CAR N)
                                                       (CAR FIELDSIZE))
                                           ,
                                           (CAR FIELDSIZE)))
                            else
                            (QUOTE IGNOREMACRO)))

(DECLARE: EVAL@COMPILE 
(PUTPROPS .ROT. MACRO ((XFORM N FIELDSIZE)
                       ((OPENLAMBDA (X)
                               (DEPOSITBYTE (LOADBYTE X (IDIFFERENCE FIELDSIZE N)
                                                   N)
                                      N
                                      (IDIFFERENCE FIELDSIZE N)
                                      X))
                        XFORM)))
)



(* NOT OK YET)


(DECLARE: EVAL@COMPILE 
(PUTPROPS LDB MACRO (X (\LDBEXPANDER X)))
(PUTPROPS DPB MACRO (X (\DPBEXPANDER X)))
[PUTPROPS BYTE MACRO
       (X (PROG ((SIZE (LISPFORM.SIMPLIFY (CAR X)
                              T))
                 (POSITION (LISPFORM.SIMPLIFY (CADR X)
                                  T)))
                (RETURN (if (AND (FIXP POSITION)
                                 (FIXP SIZE))
                            then
                            (KWOTE (create BYTESPEC BYTESPEC.SIZE _ SIZE BYTESPEC.POSITION _ POSITION
                                          ))
                            else
                            (BQUOTE (create BYTESPEC BYTESPEC.SIZE _ , SIZE BYTESPEC.POSITION _ , 
                                           POSITION]
(PUTPROPS BYTESIZE MACRO ((BYTESPEC)
                          (fetch BYTESPEC.SIZE of BYTESPEC)))
(PUTPROPS BYTEPOSITION MACRO ((BYTESPEC)
                              (fetch BYTESPEC.POSITION of BYTESPEC)))
)
(DEFINEQ

(\LDBEXPANDER

  (LAMBDA (X)                                                (* JonL "25-FEB-83 21:10")

    (PROG ((BS (LISPFORM.SIMPLIFY (CAR X)
				  T))
	   (WORD (CADR X))
	   TEM N SIZE POSITION)
          (RETURN (if
 (AND (SETQ TEM (CAR (EVALUABLE.CONSTANTP BS)))
			   (type?
 BYTESPEC TEM))
		      then
 (LIST (QUOTE LOADBYTE)
				 WORD
				 (KWOTE (BYTEPOSITION TEM))
				 (KWOTE (BYTESIZE TEM)))
		    else
 (SETQ N (LISPFORM.SIMPLIFY WORD T))
			 (if
 (AND (LISTP BS)
				  (EQ (CAR BS)
				      (QUOTE CONS))
				  (EQUAL (CADR BS)
					 (QUOTE (QUOTE BYTESPEC)))
				  (LISTP (SETQ TEM (CADDR BS)))
				  (EQ (CAR TEM)
				      (QUOTE LIST)))
			     then
                            (* What a crappy thing to do in order to try to 

							     de-compile the expanded form of 

							     (BYTE <size> <position>))

				  (pop
 TEM)
				  (SETQ SIZE (pop
 TEM))
				  (SETQ POSITION (pop
 TEM))
				  (if
 (OR (EVALUABLE.CONSTANT.FIXP N)
					  (AND (ARGS.COMMUTABLEP N SIZE)
					       (ARGS.COMMUTABLEP N POSITION)
					       (ARGS.COMMUTABLEP SIZE POSITION)))
				      then
 (BQUOTE (LOADBYTE
 , WORD , POSITION , SIZE))
				    else
 (BQUOTE ((LAMBDA (\Bytesize \Byteposition)
						     (DECLARE
 (LOCALVARS \Bytesize \Byteposition))
						     (LOADBYTE
 , WORD \Byteposition \Bytesize))
						   , SIZE , POSITION)))
			   elseif
 (AND (LITATOM BS)
				       (OR (EVALUABLE.CONSTANT.FIXP N)
					   (ARGS.COMMUTABLEP BS N)))
			     then
 (BQUOTE (LOADBYTE
 , WORD (BYTEPOSITION , BS)
						    (BYTESIZE , BS)))
			   else
 (BQUOTE ((LAMBDA (\PositionSize)
					    (DECLARE
 (LOCALVARS \PositionSize))
					    (LOADBYTE
 , WORD (BYTEPOSITION \PositionSize)
						      (BYTESIZE \PositionSize)))
					  , BS))))))))

(\DPBEXPANDER

  (LAMBDA (X)                                                (* JonL "25-FEB-83 20:49")

    (PROG ((NEWBYTE (CAR X))
	   (BS (LISPFORM.SIMPLIFY (CADR X)
				  T))
	   (WORD (LISPFORM.SIMPLIFY (CADDR X)
				    T))
	   SIZE POS X Y BagBiterP N BYTEFORM DEPOSITFORM CBSP TEM)
          (if
 (AND (LISTP BS)
		   (EQ (CAR BS)
		       (QUOTE CONS))
		   (EQUAL (CADR BS)
			  (QUOTE (QUOTE BYTESPEC)))
		   (LISTP (SETQ TEM (CADDR BS)))
		   (EQ (CAR TEM)
		       (QUOTE LIST)))
	      then
                                           (* What a crappy thing to do in order to try to 

							     de-compile the expanded form of 

							     (BYTE <size> <position>))

		   (pop
 TEM)
		   (SETQ SIZE (pop
 TEM))
		   (SETQ POS (pop
 TEM))
		   (SETQ CBSP (AND (EVALUABLE.CONSTANTP SIZE)
				   (EVALUABLE.CONSTANTP POS)))
	    elseif
 (AND (SETQ TEM (CAR (EVALUABLE.CONSTANTP BS)))
			(type?
 BYTESPEC TEM))
	      then
 (SETQ SIZE (KWOTE (BYTESIZE TEM)))
		   (SETQ POS (KWOTE (BYTEPOSITION TEM)))
		   (SETQ CBSP T))
          (SETQ N (LISPFORM.SIMPLIFY NEWBYTE T))
          (SETQ BagBiterP (OR (NOT (ARGS.COMMUTABLEP N WORD))
			      (AND (NOT CBSP)
				   (NOT (ARGS.COMMUTABLEP N BS)))))
          (SETQ BYTEFORM (if
 BagBiterP
			     then
 (QUOTE \NewByte)
			   else
 NEWBYTE))
          (SETQ DEPOSITFORM (if
 (AND SIZE POS)
				then
                         (* the SIZE and POSITION specifiers are somehow 

							     extractable.)

				     (if
 (OR CBSP (AND (ARGS.COMMUTABLEP SIZE POS)
						       (ARGS.COMMUTABLEP WORD BS)))
					 then
                (* Case with a detected constant for bytespecifier)

					      (BQUOTE (DEPOSITBYTE
 , WORD , POS , SIZE , BYTEFORM))
				       else
 (BQUOTE ((LAMBDA (\Bytesize \Byteposition)
							(DECLARE
 (LOCALVARS \Bytesize \Byteposition))
							(DEPOSITBYTE
 , WORD \Byteposition \Bytesize , 
								     BYTEFORM))
						      , SIZE , POS)))
			      else
 (if
 (AND (LITATOM BS)
					    (ARGS.COMMUTABLEP WORD BS))
				       then
 (BQUOTE (DEPOSITBYTE
 , WORD (BYTEPOSITION , BS)
								 (BYTESIZE , BS)
								 , BYTEFORM))
				     else
 (SETQ BagBiterP T)
					  (BQUOTE ((LAMBDA (\ByteSpec)
						      (DECLARE
 (LOCALVARS \ByteSpec))
						      (DEPOSITBYTE
 , WORD (BYTEPOSITION \ByteSpec)
								   (BYTESIZE \ByteSpec)
								   \NewByte))
						    , BS)))))
          (RETURN (if
 BagBiterP
		      then
 (BQUOTE ((LAMBDA (\NewByte)
				       (DECLARE
 (LOCALVARS \NewByte))
				       , DEPOSITFORM)
				     , NEWBYTE))
		    else
 DEPOSITFORM)))))
)



(* "Primitive Functions for extracting fields as integers")


(DECLARE: EVAL@COMPILE 
[PUTPROPS \XLOADBYTEWORD DMACRO ((N POS SIZE)
                                 (* N is constrained to be a SMALLP)
                                 (LOGAND (\XLRSHWORD N POS)
                                        (MASK.1'S 0 (IMIN BITSPERWORD SIZE]
)
(DEFINEQ

(\PUTBASEBITS

  [LAMBDA (ADDR POSITION SIZE VAL)                           (* lmm "12-Apr-85 15:18")

    (if
 (
GREATERP
 POSITION BITSPERWORD)
	then
 (\PUTBASEBITS
 (
\ADDBASE
 ADDR (FOLDLO POSITION BITSPERWORD))
			   (
IMOD
 POSITION BITSPERWORD)
			   SIZE VAL)
      elseif
 (
GREATERP
 SIZE (
DIFFERENCE
 BITSPERWORD POSITION))
	then
                                                 (* more than one word)

	     [\PUTBASEBITS
 ADDR POSITION (
DIFFERENCE
 BITSPERWORD POSITION)
			   (
RSH
 VAL (
SETQ
 SIZE (
DIFFERENCE
 SIZE (
DIFFERENCE
 BITSPERWORD POSITION]
	     (\PUTBASEBITS
 (
\ADDBASE
 ADDR 1)
			   0 SIZE VAL)
      else
                                                   (* a single word)

	   (
\PUTBASE
 ADDR 0 (DEPOSITBYTE
 (
\GETBASE
 ADDR 0)
					 (
DIFFERENCE
 (
SUB1
 BITSPERWORD)
						     POSITION)
					 SIZE VAL])
)



(* "Primitive functions, especially needed for CommonLisp array package.")


(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 
(PUTPROPS .HIHALFWORDLO. MACRO ((X)
                                (LRSH X BITSPERHALFWORD)))
[PUTPROPS .HIHALFWORDHI. MACRO ((X)
                                (LOGAND X (CONSTANT (LSH MASKHALFWORD1'S BITSPERHALFWORD]
(PUTPROPS .LOHALFWORDLO. MACRO ((X)
                                (LOGAND X MASKHALFWORD1'S)))
(PUTPROPS .LOHALFWORDHI. MACRO ((X)
                                (LLSH (LOGAND X MASKHALFWORD1'S)
                                      BITSPERHALFWORD)))
)

(* FOLLOWING DEFINITIONS EXPORTED)


(DECLARE: EVAL@COMPILE 
[PUTPROPS \GETBASENIBBLE DMACRO (OPENLAMBDA (BASE OFFST)
                                       ([LAMBDA (\Byte)
                                               (DECLARE (LOCALVARS \Byte))
                                               (if (ODDP OFFST)
                                                   then
                                                   (LOGAND \Byte (CONSTANT (MASK.1'S 0 BITSPERNIBBLE)
                                                                        ))
                                                   else
                                                   (LRSH \Byte BITSPERNIBBLE]
                                        (\GETBASEBYTE BASE (FOLDLO OFFST NIBBLESPERBYTE]
[PUTPROPS \PUTBASENIBBLE DMACRO
       (OPENLAMBDA (BASE OFFST VAL)
              ([LAMBDA (\ByteNo)
                      (DECLARE (LOCALVARS \ByteNo))
                      ([LAMBDA (\Byte)
                              (DECLARE (LOCALVARS \Byte))
                              (\PUTBASEBYTE BASE \ByteNo
                                     (if (ODDP OFFST)
                                         then
                                         (LOGOR (LOGAND \Byte (CONSTANT (MASK.1'S BITSPERNIBBLE 
                                                                               BITSPERNIBBLE)))
                                                VAL)
                                         else
                                         (LOGOR (LOGAND \Byte (CONSTANT (MASK.1'S 0 BITSPERNIBBLE)))
                                                (LLSH VAL BITSPERNIBBLE]
                       (\GETBASEBYTE BASE \ByteNo]
               (FOLDLO OFFST NIBBLESPERBYTE]
[PUTPROPS \GETBASEBIT DMACRO (OPENLAMBDA (BASE OFFST)
                                    ([LAMBDA (\ByteNo \BitMask)
                                            (DECLARE (LOCALVARS \ByteNo \BitMask))
                                            (if (EQ 0 (LOGAND \BitMask (\GETBASEBYTE BASE \ByteNo)))
                                                then 0 else 1]
                                     (FOLDLO OFFST BITSPERBYTE)
                                     (MASK.1'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE))
                                                      (IMOD OFFST BITSPERBYTE))
                                            1]
[PUTPROPS \PUTBASEBIT DMACRO (OPENLAMBDA (BASE OFFST VAL)
                                    ([LAMBDA (\ByteNo \BitMask \Byte)
                                            (DECLARE (LOCALVARS \ByteNo \BitMask \Byte))
                                            (SETQ \Byte (\GETBASEBYTE BASE \ByteNo))
                                            (if (if (EQ 0 (LOGAND \BitMask \Byte))
                                                    then
                                                    (NOT (EQ 0 VAL))
                                                    else
                                                    (EQ 0 VAL))
                                                then
                                                (\PUTBASEBYTE BASE \ByteNo (LOGXOR \BitMask \Byte)))
                                            VAL]
                                     (FOLDLO OFFST BITSPERBYTE)
                                     (MASK.1'S (IDIFFERENCE (CONSTANT (SUB1 BITSPERBYTE))
                                                      (IMOD OFFST BITSPERBYTE))
                                            1]
)


(* END EXPORTED DEFINITIONS)

)
(DEFINEQ

(\GETBASENIBBLE

  (LAMBDA (BASE OFFST)                                       (* JonL "16-FEB-83 19:45")

    (\MACRO.MX
 (\GETBASENIBBLE BASE OFFST))))

(\PUTBASENIBBLE

  (LAMBDA (BASE OFFST VAL)                                   (* JonL "16-FEB-83 19:52")

    (\MACRO.MX
 (\PUTBASENIBBLE BASE OFFST VAL))))

(\GETBASEBIT

  (LAMBDA (BASE OFFST)                                       (* JonL "27-JAN-83 20:34")

    (\MACRO.MX
 (\GETBASEBIT BASE OFFST))))

(\PUTBASEBIT

  (LAMBDA (BASE OFFST VAL)                                   (* JonL " 7-FEB-83 21:01")

    (\MACRO.MX
 (\PUTBASEBIT BASE OFFST VAL))))
)



(* "Beginning of rewrite of some LLARITH things, modularly using the macros of 
	   this file")


(DECLARE: DONTCOPY 
(* FOLLOWING DEFINITIONS EXPORTED)



(RPAQQ MASK0WORD1'S
 32767)

(RPAQQ MASK1WORD0'S
 32768)

(RPAQQ MASKWORD1'S
 65535)

(RPAQQ MASKHALFWORD1'S
 255)

(RPAQQ BITSPERHALFWORD
 8)
(DECLARE: EVAL@COMPILE 
(CONSTANTS MASK0WORD1'S MASK1WORD0'S MASKWORD1'S MASKHALFWORD1'S BITSPERHALFWORD)
)
(DECLARE: EVAL@COMPILE 
(PUTPROPS EQZEROP MACRO ((X)
                         (EQ 0 X)))
)
(DECLARE: EVAL@COMPILE 
[PUTPROPS \MOVETOBOX DMACRO (OPENLAMBDA (N D)
                                   (SELECTC (NTYPX N)
                                          (\SMALLP (replace (FIXP HINUM)
                                                          of D with 0)
                                                 (replace (FIXP LONUM)
                                                        of D with N))
                                          (\FIXP (replace (FIXP HINUM)
                                                        of D with (fetch (FIXP HINUM)
                                                                         of N))
                                                 (replace (FIXP LONUM)
                                                        of D with (fetch (FIXP LONUM)
                                                                         of N)))
                                          (\ILLEGAL.ARG N]
[PUTPROPS .XUNBOX. MACRO ((X HX LX)
                          (until (SETQ LX (SELECTC (NTYPX X)
                                                 [\SMALLP (COND ((IGEQ X 0)
                                                                 (SETQ HX 0)
                                                                 X)
                                                                (T (SETQ HX MASKWORD1'S)
                                                                   (\LOLOC X]
                                                 (\FIXP (SETQ HX (fetch (FIXP HINUM)
                                                                        of X))
                                                        (fetch (FIXP LONUM)
                                                               of X))
                                                 NIL))
                                 do
                                 (SETQ X (LISPERROR "ILLEGAL ARG" X T]
[PUTPROPS .XLLSH. MACRO ((HI LO N)
                         (if (IGEQ N BITSPERWORD)
                             then
                             (* Jump 16 bits in a single bound!)
                             (SETQ HI LO)
                             (SETQ LO 0)
                             (SETQ N (IDIFFERENCE N BITSPERWORD)))
                         (if (IGEQ N BITSPERHALFWORD)
                             then
                             (* Jump 8 bits in a single bound!)
                             (SETQ HI (LOGOR (.LOHALFWORDHI. HI)
                                             (.HIHALFWORDLO. LO)))
                             (SETQ LO (.LOHALFWORDHI. LO))
                             (SETQ N (IDIFFERENCE N BITSPERHALFWORD)))
                         (if (IGEQ N 4)
                             then
                             (* Jump 4 bits in a single bound!)
                             (SETQ HI (LOGOR (LRSH LO (CONSTANT (IDIFFERENCE BITSPERWORD 4)))
                                             (LLSH [LOGAND HI (CONSTANT (MASK.1'S 0 (IDIFFERENCE
                                                                                     BITSPERWORD 4]
                                                   4)))
                             (SETQ LO (LLSH [LOGAND LO (CONSTANT (MASK.1'S 0 (IDIFFERENCE BITSPERWORD 
                                                                                    4]
                                            4))
                             (SETQ N (IDIFFERENCE N 4)))
                         [* MASK0WORD1'S should be same as (SUB1 (LSH 1 (SUB1 BITSPERWORD]
                         (FRPTQ N (SETQ HI (LLSH (LOGAND HI MASK0WORD1'S)
                                                 1))
                                (SETQ LO (LLSH (if (IGEQ LO MASK1WORD0'S)
                                                   then
                                                   (add HI 1)
                                                   (LOGAND LO MASK0WORD1'S)
                                                   else LO)
                                               1]
[PUTPROPS .XLLSH1. MACRO ((HI LO)
                          (SETQ HI (LLSH (LOGAND HI MASK0WORD1'S)
                                         1))
                          (SETQ LO (LSH (COND ((IGEQ LO MASK1WORD0'S)
                                               (SETQ HI (LOGOR HI 1))
                                               (LOGAND LO MASK0WORD1'S))
                                              (T LO))
                                        1]
[PUTPROPS .XLRSH. MACRO ((HI LO N)
                         (if (IGEQ N BITSPERWORD)
                             then
                             (* Jump 10 bits in a single bound!)
                             (SETQ LO HI)
                             (SETQ HI 0)
                             (SETQ N (IDIFFERENCE N BITSPERWORD)))
                         (if (IGEQ N BITSPERHALFWORD)
                             then
                             (* Jump 8 bits in a single bound!)
                             (SETQ LO (LOGOR (.HIHALFWORDLO. LO)
                                             (.LOHALFWORDHI. HI)))
                             (SETQ HI (.HIHALFWORDLO. HI))
                             (SETQ N (IDIFFERENCE N BITSPERHALFWORD)))
                         (if (IGEQ N 4)
                             then
                             (* Jump 4 bits in a single bound!)
                             (SETQ LO (LOGOR (LLSH (LOGAND HI (CONSTANT (MASK.1'S 0 4)))
                                                   (CONSTANT (IDIFFERENCE BITSPERWORD 4)))
                                             (LRSH LO 4)))
                             (SETQ HI (LRSH HI 4))
                             (SETQ N (IDIFFERENCE N 4)))
                         (* MASK1WORD0'S should be same as \SIGNBIT)
                         (FRPTQ N (SETQ LO (if (ODDP HI)
                                               then
                                               (LOGOR (LRSH LO 1)
                                                      MASK1WORD0'S)
                                               else
                                               (LRSH LO 1)))
                                (SETQ HI (LRSH HI 1]
[PUTPROPS .ADD.2WORD.INTEGERS. MACRO ((HX LX HY LY)
                                      (* Ignores carry out of high-order word)
                                      (SETQ HX (.SUMSMALLMOD. HX HY))
                                      (SETQ LX (.SUMSMALLMOD. LX LY (SETQ HX
                                                                          (if (EQ HX 
                                                                                  MAX.SMALL.INTEGER)
                                                                              then 0 else
                                                                              (ADD1 HX]
[PUTPROPS .SUB.2WORD.INTEGERS. MACRO ((HX LX HY LY)
                                      (* Ignores carry out of high-order word)
                                      (SETQ HX (.DIFFERENCESMALLMOD. HX HY))
                                      (SETQ LX (.DIFFERENCESMALLMOD. LX LY
                                                      (SETQ HX (if (EQ HX 0)
                                                                   then MAX.SMALL.INTEGER else
                                                                   (SUB1 HX]
[PUTPROPS .32BITMUL. MACRO ((HR LR X Y)
                            (PROG (HX LX HY LY)
                                  (if (ILESSP X Y)
                                      then
                                      (swap X Y))
                                  (* Y is the lesser of the two now)
                                  (.XUNBOX. X HX LX)
                                  (.XUNBOX. Y HY LY)
                                  LP
                                  (if (ODDP LY)
                                      then
                                      (.ADD.2WORD.INTEGERS. HR LR HX LX))
                                  (if (EQ HY 0)
                                      then
                                      (SETQ LY (LRSH LY 1))
                                      (if (EQ LY 0)
                                          then
                                          (RETURN))
                                      else
                                      (.LRSH1. HY LY))
                                  (* Trim off highest bits, so that left-shifting doesn't generate 
                                     FIXPs)
                                  (SETQ HX (LOGAND HX MASK0WORD1'S))
                                  (.LLSH1. HX LX)
                                  (GO LP]
)
(DECLARE: EVAL@COMPILE 
[PUTPROPS .SUMSMALLMOD. MACRO ((X Y OVERFLOWFORM)
                               ([LAMBDA (\SumSmallModVar)
                                       (DECLARE (LOCALVARS \SumSmallModVar))
                                       (IF (ILEQ X \SumSmallModVar)
                                           THEN
                                           (IPLUS X Y)
                                           ELSE OVERFLOWFORM (IDIFFERENCE X (ADD1 \SumSmallModVar]
                                (IDIFFERENCE MAX.SMALL.INTEGER Y]
[PUTPROPS .DIFFERENCESMALLMOD. MACRO ((X Y BORROWFORM)
                                      (IF (NOT (IGREATERP Y X))
                                          THEN
                                          (IDIFFERENCE X Y)
                                          ELSE BORROWFORM (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER
                                                                       (IDIFFERENCE Y X]
)


(* END EXPORTED DEFINITIONS)


(DECLARE: EVAL@COMPILE 
[PUTPROPS .ADD.2WORD.INTEGERS. MACRO ((HX LX HY LY)
                                      (* Ignores carry out of high-order word)
                                      (SETQ HX (.SUMSMALLMOD. HX HY))
                                      (SETQ LX (.SUMSMALLMOD. LX LY (SETQ HX
                                                                          (if (EQ HX 
                                                                                  MAX.SMALL.INTEGER)
                                                                              then 0 else
                                                                              (ADD1 HX]
[PUTPROPS .SUB.2WORD.INTEGERS. MACRO ((HX LX HY LY)
                                      (* Ignores carry out of high-order word)
                                      (SETQ HX (.DIFFERENCESMALLMOD. HX HY))
                                      (SETQ LX (.DIFFERENCESMALLMOD. LX LY
                                                      (SETQ HX (if (EQ HX 0)
                                                                   then MAX.SMALL.INTEGER else
                                                                   (SUB1 HX]
[PUTPROPS .32BITMUL. MACRO ((HR LR X Y)
                            (PROG (HX LX HY LY)
                                  (if (ILESSP X Y)
                                      then
                                      (swap X Y))
                                  (* Y is the lesser of the two now)
                                  (.XUNBOX. X HX LX)
                                  (.XUNBOX. Y HY LY)
                                  LP
                                  (if (ODDP LY)
                                      then
                                      (.ADD.2WORD.INTEGERS. HR LR HX LX))
                                  (if (EQ HY 0)
                                      then
                                      (SETQ LY (LRSH LY 1))
                                      (if (EQ LY 0)
                                          then
                                          (RETURN))
                                      else
                                      (.LRSH1. HY LY))
                                  (* Trim off highest bits, so that left-shifting doesn't generate 
                                     FIXPs)
                                  (SETQ HX (LOGAND HX MASK0WORD1'S))
                                  (.LLSH1. HX LX)
                                  (GO LP]
)
)
(PUTPROPS ADDARITH COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (3095 8115 (\RTIMES2 3105 . 4651) (\RATIONALIZE 4653 . 4988) (\RPLUS2 4990 . 6356) (
\RMINUS 6358 . 6695) (CREATERATIONAL 6697 . 7867) (RATIONALTOINTEGER 7869 . 8113)) (9107 9423 (
LOADBYTE 9117 . 9263) (DEPOSITBYTE 9265 . 9421)) (9848 10449 (IMODLESSP 9858 . 10037) (IMODPLUS 10039
 . 10286) (IMODDIFFERENCE 10288 . 10447)) (11335 11766 (ROT 11345 . 11764)) (13919 18429 (\LDBEXPANDER
 13929 . 15756) (\DPBEXPANDER 15758 . 18427)) (18775 19702 (\PUTBASEBITS 18785 . 19700)) (23845 24503 
(\GETBASENIBBLE 23855 . 24016) (\PUTBASENIBBLE 24018 . 24183) (\GETBASEBIT 24185 . 24340) (\PUTBASEBIT
 24342 . 24501)))))
STOP