(FILECREATED "20-OCT-83 11:40:10" {PHYLUM}<LISPCORE>SOURCES>ADDARITH.;95
 59356  

      changes to:  (FNS \VectorREF \VectorSET \VectorLENGTH \MakeVector)
		   (VARS ADDARITHCOMS)

      previous date: "28-SEP-83 21:14:00" {PHYLUM}<LISPCORE>SOURCES>ADDARITH.;93)


(* Copyright (c) 1982, 1983 by Xerox Corporation)

(PRETTYCOMPRINT ADDARITHCOMS)

(RPAQQ ADDARITHCOMS
 ((DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (P (SETQ CLISPIFTRANFLG T)))
		     (LOCALVARS . T)
		     (RECORDS RATIONAL)
		     (COMS (* These facilities should be common with Interlisp-10 and Interlisp-VAX)
			   (COMS (* Vectors are "fast" equivalents to 0-origin POINTER arrays)
				 (MACROS \MakeVector \VectorREF \VectorSET)
				 (FNS \VectorLENGTH \MakeVector \VectorREF \VectorSET))
			   (COMS (* Bit mask functions)
				 (FNS \SETUP.MASKARRAYS)
				 (PROP GLOBALVAR \RJ1M \MASKOUT.MARGIN)
				 (DECLARE: DONTEVAL@LOAD DOCOPY (P (\SETUP.MASKARRAYS)))
				 (MACROS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT)
				 (FNS \MASK.1'S.EXPANDER)
				 (FNS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT)
				 (DECLARE: DONTCOPY EVAL@COMPILE (* Grumble lossaged due to failure 
								    of (FNS ...)
								    when merely EVAL@COMPILE)
					   (FNS \MASK.1'S.EXPANDER)))
			   (COMS (* BYTE hacking functions)
				 (RECORDS BYTESPEC)
				 (DECLARE: DONTCOPY (EXPORT (MACROS \CHECK.BYTESPEC \INDEXABLE.FIXP)))
				 (FNS LOADBYTE DEPOSITBYTE)
				 (MACROS LOADBYTE DEPOSITBYTE LDB DPB BYTE BYTESIZE BYTEPOSITION)
				 (FNS \LDBEXPANDER \DPBEXPANDER \LOADBYTEEXPANDER 
				      \DEPOSITBYTEEXPANDER)
				 (DECLARE: DONTCOPY EVAL@COMPILE (* Grumble lossaged due to failure 
								    of (FNS ...)
								    when merely EVAL@COMPILE)
					   (FNS \LOADBYTEEXPANDER \DEPOSITBYTEEXPANDER))))
		     (DECLARE: DONTCOPY (MACROS .HIHALFWORDLO. .HIHALFWORDHI. .LOHALFWORDLO. 
						.LOHALFWORDHI.)
			       (EXPORT (MACROS .XUNBOX. \MOVETOBOX .XLLSH. .XLRSH. .XLLSH1. 
					       .SUMSMALLMOD. .DIFFERENCESMALLMOD. 
					       .ADD.2WORD.INTEGERS. .SUB.2WORD.INTEGERS. .32BITMUL.)))
		     (COMS (* Some version of the following should be done in MACHINEDEPENDENT for 
			      the other Interlisps.)
			   (GLOBALRESOURCES (\MODLESSPBOX (NCREATE (QUOTE FIXP))))
			   (FNS IMODLESSP IMODPLUS IMODDIFFERENCE)
			   (MACROS IMODPLUS IMODDIFFERENCE)
			   (FNS ROT)
			   (MACROS ROT)
			   (FNS \ROTexpander))
		     (COMS (* Primitive Functions for extracting fields as integers)
			   (MACROS \XLOADBYTEWORD)
			   (FNS \XLOADBYTE \XLOADBYTEWORD \XDEPOSITBYTE \XDEPOSITBYTEWORD \XLLSHWORD 
				\XLRSHWORD)
			   (FNS \GETBASEBITS \PUTBASEBITS \GETBASEINTEGER \PUTBASEINTEGER)
			   (* Primitive functions, especially needed for CommonLisp array package.)
			   (EXPORT (DECLARE: DONTCOPY (MACROS \GETBASEFLOATP \PUTBASEFLOATP 
							      \GETBASEFIXP \PUTBASEFIXP 
							      \GETBASENIBBLE \PUTBASENIBBLE 
							      \GETBASEBIT \PUTBASEBIT)))
			   (FNS \GETBASEFLOATP \PUTBASEFLOATP \GETBASEFIXP \PUTBASEFIXP 
				\GETBASENIBBLE \PUTBASENIBBLE \GETBASEBIT \PUTBASEBIT))
		     (COMS (* Beginning of rewrite of some LLARITH things, modularly using the macros 
			      of this file)
			   (FNS NEWTRUNCATEMULTIPLY))))
(DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD 
(SETQ CLISPIFTRANFLG T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
[DECLARE: EVAL@COMPILE 

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



(* These facilities should be common with Interlisp-10 and Interlisp-VAX)





(* Vectors are "fast" equivalents to 0-origin POINTER arrays)


(DECLARE: EVAL@COMPILE 

(PUTPROPS \MakeVector DMACRO 
((N)
  (\ALLOCBLOCK N PTRBLOCK.GCT)))

(PUTPROPS \VectorREF DMACRO 
((V I)
  (\GETBASEPTR V (LLSH I 1))))

(PUTPROPS \VectorSET DMACRO 
((V I VAL)
  (\RPLPTR V (LLSH I 1)
	   VAL)))
)
(DEFINEQ

(\VectorLENGTH

  (LAMBDA (X)                                                (* JonL "20-OCT-83 10:55")

    (OR (type?
 ARRAYBLOCK X)
	(\ILLEGAL.ARG X))
    (\#BLOCKDATACELLS X)))

(\MakeVector

  (LAMBDA (N)                                                (* JonL "20-OCT-83 10:52")

    (\MACRO.MX
 (\MakeVector N))))

(\VectorREF

  (LAMBDA (X I)                                              (* JonL "20-OCT-83 11:39")

    (OR (type?
 ARRAYBLOCK X)
	(\ILLEGAL.ARG X))
    (\MACRO.MX
 (\VectorREF X I))))

(\VectorSET

  (LAMBDA (X I VAL)                                          (* JonL "20-OCT-83 11:39")

    (OR (type?
 ARRAYBLOCK X)
	(\ILLEGAL.ARG X))
    (\MACRO.MX
 (\VectorSET X I VAL))))
)



(* Bit mask functions)


(DEFINEQ

(\SETUP.MASKARRAYS

  (LAMBDA NIL                                                (* JonL "22-JAN-83 22:58")

                                                             (* \RJ1M is a Vector of right-justified 1's masks.

							     \MASKOUT.MARGIN is a 2-dim Vector of 1's masks, in all 

							     possible alignments in a cell.)

    (SETQ \RJ1M (\MakeVector (ADD1 BITS.PER.FIXP)))
    (\VectorSET \RJ1M BITS.PER.FIXP -1)
    (for
 K from
 0 to
 (PROG1 (SUB1 BITS.PER.FIXP)             (* Comment PPLossage)

			    )
       do
 (\VectorSET \RJ1M K (SUB1 (LLSH 1 K))))
    (SETQ \MASKOUT.MARGIN (\MakeVector (ADD1 BITS.PER.FIXP)))
                                                             (* Each element of \MASKOUT.MARGIN is a vector of masks,

							     where increasing indices means increasing start-position

							     of the mask.)

    (\VectorSET \MASKOUT.MARGIN 0 \RJ1M)
    (for
 POS from
 1 to
 BITS.PER.FIXP bind
 MASKARRAY MAXFIELDSIZE
       do
 (SETQ MAXFIELDSIZE (IDIFFERENCE BITS.PER.FIXP POS))
	  (SETQ MASKARRAY (\MakeVector (ADD1 MAXFIELDSIZE)))
	  (for
 K from
 0 to
 (PROG1 MAXFIELDSIZE               (* Comment PPLossage)
)
	     do
 (\VectorSET MASKARRAY K (LLSH (\VectorREF \RJ1M K)
					      POS)))
	  (\VectorSET \MASKOUT.MARGIN POS MASKARRAY))))
)

(PUTPROPS \RJ1M GLOBALVAR 
T)

(PUTPROPS \MASKOUT.MARGIN GLOBALVAR 
T)
(DECLARE: DONTEVAL@LOAD DOCOPY 
(\SETUP.MASKARRAYS)
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS MASK.1'S MACRO 
(X
  (\MASK.1'S.EXPANDER X)))

(PUTPROPS MASK.0'S MACRO 
(X
  (PROG ((POSITION (CAR X))
	 (SIZE (CADR X))
	 TEM)                                                (* This used to have a lot more in it, but I decided 

							     that it really isn't an important function.)

        (RETURN (if
 (AND (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
			 (SETQ POSITION TEM)
			 (SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
			 (SETQ SIZE TEM))
		    then
 (MASK.0'S POSITION SIZE)
		  else
 (LIST (QUOTE LOGNOT)
			     (LIST (QUOTE 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 (LOGXOR -1 MASK))))

(PUTPROPS LOGNOT MACRO 
((N) (LOGXOR -1 N)))
)
(DEFINEQ

(\MASK.1'S.EXPANDER

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

    (PROG ((POSITION (CAR X))
	   (SIZE (CADR X))
	   TEM)
          (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
	      then
 (SETQ POSITION TEM)
		   (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
		       then
 (SETQ SIZE TEM)
			    (\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
			    (RETURN (\VectorREF (\VectorREF \MASKOUT.MARGIN POSITION)
						SIZE))
		     elseif
 (ZEROP POSITION)
		       then
 (RETURN (LIST (QUOTE \VectorREF)
					  (QUOTE \RJ1M)
					  SIZE))))
          (RETURN (LIST (QUOTE \VectorREF)
			(LIST (QUOTE \VectorREF)
			      (QUOTE \MASKOUT.MARGIN)
			      POSITION)
			SIZE)))))
)
(DEFINEQ

(MASK.1'S

  (LAMBDA (POSITION SIZE)                                    (* JonL "24-OCT-82 18:13")


          (* This function restricts it's arguments so that the open-coded expansion is valid for any correct set of 

	  arguments; the open-coding cannot do coercion since the D version just does \GETBASEPTR using the input args as 

	  indices.)



    (\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
    (\MACRO.MX
 (MASK.1'S POSITION SIZE))))

(MASK.0'S

  (LAMBDA (POSITION SIZE)                                    (* JonL "22-OCT-82 21:28")

                                                             (* FOO, so this may cons on larger numbers, but probably

							     this functions isn't all that important.)

    (LOGNOT
 (APPLY* (FUNCTION MASK.1'S)
		    POSITION SIZE))))

(BITTEST

  (LAMBDA (N MASK)                                           (* JonL "26-FEB-83 12:36")

    (\MACRO.MX
 (BITTEST N MASK))))

(BITSET

  (LAMBDA (N MASK)                                           (* JonL "26-FEB-83 12:37")

    (\MACRO.MX
 (BITSET N MASK))))

(BITCLEAR

  (LAMBDA (N MASK)                                           (* JonL "26-FEB-83 12:36")

    (\MACRO.MX
 (BITCLEAR N MASK))))

(LOGNOT

  (LAMBDA (N)                                                (* JonL "24-JUL-82 01:14")

    (LOGXOR -1 N)))
)
(DECLARE: DONTCOPY EVAL@COMPILE 



(* Grumble lossaged due to failure of (FNS ...) when merely EVAL@COMPILE)



(DEFINEQ

(\MASK.1'S.EXPANDER

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

    (PROG ((POSITION (CAR X))
	   (SIZE (CADR X))
	   TEM)
          (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP POSITION))
	      then
 (SETQ POSITION TEM)
		   (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP SIZE))
		       then
 (SETQ SIZE TEM)
			    (\CHECK.BYTESPEC POSITION SIZE BITS.PER.FIXP)
			    (RETURN (\VectorREF (\VectorREF \MASKOUT.MARGIN POSITION)
						SIZE))
		     elseif
 (ZEROP POSITION)
		       then
 (RETURN (LIST (QUOTE \VectorREF)
					  (QUOTE \RJ1M)
					  SIZE))))
          (RETURN (LIST (QUOTE \VectorREF)
			(LIST (QUOTE \VectorREF)
			      (QUOTE \MASKOUT.MARGIN)
			      POSITION)
			SIZE)))))
)
)



(* BYTE hacking functions)


[DECLARE: EVAL@COMPILE 

(TYPERECORD BYTESPEC
 (BYTESPEC.SIZE BYTESPEC.POSITION))
]
(DECLARE: DONTCOPY 
(* FOLLOWING DEFINITIONS EXPORTED)


(DECLARE: EVAL@COMPILE 

(PUTPROPS \CHECK.BYTESPEC MACRO 
(X
  (PROG ((POS (CAR X))
	 (SIZE (CADR X))
	 (LENGTHLIMIT (CADDR X)))                            (* Currently, this macro may only be call with "pos" and

							     "size" arguments as litatoms, so that they may be 
"SETQ'd" in-line.)

        (if
 (NOT (NNLITATOM POS))
	    then
 (SETERRORN 14 POS)
		 (ERRORX)
	  elseif
 (NOT (NNLITATOM SIZE))
	    then
 (SETERRORN 14 SIZE)
		 (ERRORX)
	  elseif
 (AND LENGTHLIMIT (NOT (LITATOM LENGTHLIMIT)))
	    then
 (SETERRORN 14 LENGTHLIMIT)
		 (ERRORX))
        (RETURN (BQUOTE (PROGN (\CHECKTYPE , POS (AND (\INDEXABLE.FIXP , POS)
						      ,@(AND LENGTHLIMIT
							     (BQUOTE ((ILEQ , POS , LENGTHLIMIT))))))
			       (\CHECKTYPE , SIZE
					   (AND (\INDEXABLE.FIXP , SIZE)
						,@(AND LENGTHLIMIT
						       (BQUOTE ((ILEQ (IPLUS , POS , SIZE)
								      , LENGTHLIMIT))))))))))))

(PUTPROPS \INDEXABLE.FIXP MACRO 
(OPENLAMBDA (X)
  (AND (FIXP X)
       (IGEQ X 0))))

(PUTPROPS \INDEXABLE.FIXP DMACRO 
(OPENLAMBDA (X)
  (AND (SMALLP X)
       (IGEQ X 0))))
)


(* END EXPORTED DEFINITIONS)

)
(DEFINEQ

(LOADBYTE

  (LAMBDA (N POS SIZE)                                       (* JonL "28-SEP-83 21:08")

    (\CHECK.BYTESPEC POS SIZE)
    (PROG NIL
      A   (RETURN (SELECTC (NTYPX N)
			   (\SMALLP (\XLOADBYTEWORD
 N POS SIZE))
			   (\FIXP (\XLOADBYTE
 N POS SIZE))
			   (PROGN (SETQ N (LISPERROR "ILLEGAL ARG" N T))
				  (GO A)))))))

(DEPOSITBYTE

  (LAMBDA (N POS SIZE VAL)                                   (* JonL "28-SEP-83 21:08")

                                                             (* Limits set due to BITS.PER.FIXP are because we can't 

							     create a BIGNUM answer yet.)

    (\CHECK.BYTESPEC POS SIZE BITS.PER.FIXP)
    (PROG (EXTENT)
      A   (RETURN (if
 (AND (SMALLP N)
			   (ILEQ (SETQ EXTENT (IPLUS POS SIZE))
				 BITSPERWORD))
		      then
 (\XDEPOSITBYTEWORD
 N POS SIZE VAL EXTENT)
		    elseif
 (FIXP N)
		      then
 (\XDEPOSITBYTE
 N POS SIZE VAL)
		    else
 (SETQ N (LISPERROR "ILLEGAL ARG" N T))
			 (GO A))))))
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS LOADBYTE MACRO 
(X
  (\LOADBYTEEXPANDER X)))

(PUTPROPS DEPOSITBYTE MACRO 
(X
  (\DEPOSITBYTEEXPANDER X)))

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

(\LOADBYTEEXPANDER

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

    ((LAMBDA (SIZE)
	(SETQ SIZE (EVALUABLE.CONSTANT.FIXP (CADDR X)))
	(if
 (NULL SIZE)
	    then
 ((LAMBDA (POS)
		     (if
 POS
			 then
 (BQUOTE (LOGAND (LRSH , (CAR X)
						    , POS)
					      (MASK.1'S
 0 , (CADDR X))))
		       else
 (QUOTE IGNOREMACRO)))
		   (EVALUABLE.CONSTANT.FIXP (CADR X)))
	  else
 (if
 (OR (NOT (\INDEXABLE.FIXP SIZE))
		       (NOT (IGEQ SIZE 0)))
		   then
 (ERROR (CADDR X)
			       "Byte size out of range"))
	       (if
 (ZEROP SIZE)
		   then
 (LIST (QUOTE PROGN)
			      (CAR X)
			      (CADR X)
			      0)
		 else
 (PROG ((WORD (CAR X))
			     (POS (CADR X))
			     (MASK (if
 (ILEQ SIZE BITS.PER.FIXP)
				       then
 (MASK.1'S
 0 SIZE)
				     else
 (BITCLEAR
 -1 (LLSH -1 SIZE))))
			     TEM)
			    (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP POS))
				then
                         (* The position is constant)

				     (if
 (OR (NOT (\INDEXABLE.FIXP TEM))
					     (NOT (IGEQ TEM 0)))
					 then
 (ERROR POS "Byte position out of range"))
				     (SETQ POS TEM)
				     (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP WORD))
					 then
 (RETURN (LOADBYTE
 TEM POS SIZE))))
			    (RETURN (LIST (QUOTE LOGAND)
					  (if
 (ZEROP POS)
					      then
 WORD
					    else
 (LIST (QUOTE LRSH)
						       WORD POS))
					  MASK)))))))))

(\DEPOSITBYTEEXPANDER

  (LAMBDA (X)                                                (* JonL "28-SEP-83 21:10")

    ((LAMBDA (POS SIZE)
	(if
 (AND SIZE (ILEQ SIZE 0))
	    then
 (if
 (ZEROP SIZE)
		     then
 (LIST (QUOTE PROG1)
				(CAR X)
				(CADR X)
				(CADDDR X))
		   else
 (ERROR (CADDR X)
			       "Byte size out of range"))
	  elseif
 (AND POS (ILESSP POS 0))
	    then
 (ERROR (CADR X)
			"Byte position out of range")
	  elseif
 (OR (NULL SIZE)
		     (NULL POS)
		     (SELECTQ (SYSTEMTYPE)
			      (D (ILESSP BITSPERCELL (IPLUS POS SIZE)))
			      NIL))
	    then
                                             (* Unless both Position and Size are constant, then the 

							     open-coded formula has too much likelihood of CONSing)

		 (QUOTE IGNOREMACRO)
	  elseif
 (ILESSP BITSPERWORD (IPLUS POS SIZE))
	    then
                                             (* For D machines, if the constant byte isn't wholly 

							     contained within a word-sized number, then again there 

							     is too much likelihood of CONSing)

		 (CONS (QUOTE \XDEPOSITBYTE)
		       X)
	  else
 (PROG ((WORD (CAR X))
		      (VAL (CADDDR X))
		      (MASK (if
 (ILEQ SIZE BITS.PER.FIXP)
				then
 (MASK.1'S
 0 SIZE)
			      else
 (BITCLEAR
 -1 (LLSH -1 SIZE))))
		      NWORD NVAL)
		     (SETQ NWORD (EVALUABLE.CONSTANT.FIXP WORD))
		     (AND (SETQ NVAL (EVALUABLE.CONSTANT.FIXP VAL))
			  (SETQ NVAL (LOGAND NVAL MASK)))
		     (RETURN (if
 (AND NWORD NVAL)
				 then
 (\XDEPOSITBYTE
 NWORD POS SIZE NVAL)
			       elseif
 NWORD
				 then
                        (* So VAL is now know not to be numeric 

							     (or else the preceeding clause would have been taken))

				      ((LAMBDA (SHIFTEDVAL)
					  (if
 (NEQ POS 0)
					      then
 (SETQ SHIFTEDVAL (LIST (QUOTE LLSH)
									  SHIFTEDVAL POS)))
					  (if
 (ZEROP (SETQ NWORD (BITCLEAR
 NWORD (LLSH MASK POS))))
					      then
 SHIFTEDVAL
					    else
 (LIST (QUOTE LOGOR)
						       NWORD SHIFTEDVAL)))
					(LIST (QUOTE LOGAND)
					      VAL MASK))
			       else
 ((LAMBDA (MWORD)
					(if
 (AND NVAL (ZEROP (SETQ NVAL (LOGAND NVAL MASK))))
					    then
             (* Depositing a byte of 0's)

						 MWORD
					  elseif
 (AND NVAL (EQ MASK NVAL))
					    then
             (* Depositing a byte of 1'S)

						 (CONS (QUOTE BITSET)
						       (CDR MWORD))
					  else
 (if
 NVAL
						   then
 (SETQ VAL (LLSH NVAL POS))
						 else
 (SETQ VAL (BQUOTE (LOGAND , VAL , MASK)))
						      (if
 (NOT (ZEROP POS))
							  then
 (SETQ VAL (LIST (QUOTE LLSH)
									       VAL POS))))
					       (BQUOTE (LOGOR , MWORD , VAL))))
				      (BQUOTE (BITCLEAR
 , WORD , (LLSH MASK POS)))))))))
      (EVALUABLE.CONSTANT.FIXP (CADR X))
      (EVALUABLE.CONSTANT.FIXP (CADDR X)))))
)
(DECLARE: DONTCOPY EVAL@COMPILE 



(* Grumble lossaged due to failure of (FNS ...) when merely EVAL@COMPILE)



(DEFINEQ

(\LOADBYTEEXPANDER

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

    ((LAMBDA (SIZE)
	(SETQ SIZE (EVALUABLE.CONSTANT.FIXP (CADDR X)))
	(if
 (NULL SIZE)
	    then
 ((LAMBDA (POS)
		     (if
 POS
			 then
 (BQUOTE (LOGAND (LRSH , (CAR X)
						    , POS)
					      (MASK.1'S
 0 , (CADDR X))))
		       else
 (QUOTE IGNOREMACRO)))
		   (EVALUABLE.CONSTANT.FIXP (CADR X)))
	  else
 (if
 (OR (NOT (\INDEXABLE.FIXP SIZE))
		       (NOT (IGEQ SIZE 0)))
		   then
 (ERROR (CADDR X)
			       "Byte size out of range"))
	       (if
 (ZEROP SIZE)
		   then
 (LIST (QUOTE PROGN)
			      (CAR X)
			      (CADR X)
			      0)
		 else
 (PROG ((WORD (CAR X))
			     (POS (CADR X))
			     (MASK (if
 (ILEQ SIZE BITS.PER.FIXP)
				       then
 (MASK.1'S
 0 SIZE)
				     else
 (BITCLEAR
 -1 (LLSH -1 SIZE))))
			     TEM)
			    (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP POS))
				then
                         (* The position is constant)

				     (if
 (OR (NOT (\INDEXABLE.FIXP TEM))
					     (NOT (IGEQ TEM 0)))
					 then
 (ERROR POS "Byte position out of range"))
				     (SETQ POS TEM)
				     (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP WORD))
					 then
 (RETURN (LOADBYTE
 TEM POS SIZE))))
			    (RETURN (LIST (QUOTE LOGAND)
					  (if
 (ZEROP POS)
					      then
 WORD
					    else
 (LIST (QUOTE LRSH)
						       WORD POS))
					  MASK)))))))))

(\DEPOSITBYTEEXPANDER

  (LAMBDA (X)                                                (* JonL "28-SEP-83 21:10")

    ((LAMBDA (POS SIZE)
	(if
 (AND SIZE (ILEQ SIZE 0))
	    then
 (if
 (ZEROP SIZE)
		     then
 (LIST (QUOTE PROG1)
				(CAR X)
				(CADR X)
				(CADDDR X))
		   else
 (ERROR (CADDR X)
			       "Byte size out of range"))
	  elseif
 (AND POS (ILESSP POS 0))
	    then
 (ERROR (CADR X)
			"Byte position out of range")
	  elseif
 (OR (NULL SIZE)
		     (NULL POS)
		     (SELECTQ (SYSTEMTYPE)
			      (D (ILESSP BITSPERCELL (IPLUS POS SIZE)))
			      NIL))
	    then
                                             (* Unless both Position and Size are constant, then the 

							     open-coded formula has too much likelihood of CONSing)

		 (QUOTE IGNOREMACRO)
	  elseif
 (ILESSP BITSPERWORD (IPLUS POS SIZE))
	    then
                                             (* For D machines, if the constant byte isn't wholly 

							     contained within a word-sized number, then again there 

							     is too much likelihood of CONSing)

		 (CONS (QUOTE \XDEPOSITBYTE)
		       X)
	  else
 (PROG ((WORD (CAR X))
		      (VAL (CADDDR X))
		      (MASK (if
 (ILEQ SIZE BITS.PER.FIXP)
				then
 (MASK.1'S
 0 SIZE)
			      else
 (BITCLEAR
 -1 (LLSH -1 SIZE))))
		      NWORD NVAL)
		     (SETQ NWORD (EVALUABLE.CONSTANT.FIXP WORD))
		     (AND (SETQ NVAL (EVALUABLE.CONSTANT.FIXP VAL))
			  (SETQ NVAL (LOGAND NVAL MASK)))
		     (RETURN (if
 (AND NWORD NVAL)
				 then
 (\XDEPOSITBYTE
 NWORD POS SIZE NVAL)
			       elseif
 NWORD
				 then
                        (* So VAL is now know not to be numeric 

							     (or else the preceeding clause would have been taken))

				      ((LAMBDA (SHIFTEDVAL)
					  (if
 (NEQ POS 0)
					      then
 (SETQ SHIFTEDVAL (LIST (QUOTE LLSH)
									  SHIFTEDVAL POS)))
					  (if
 (ZEROP (SETQ NWORD (BITCLEAR
 NWORD (LLSH MASK POS))))
					      then
 SHIFTEDVAL
					    else
 (LIST (QUOTE LOGOR)
						       NWORD SHIFTEDVAL)))
					(LIST (QUOTE LOGAND)
					      VAL MASK))
			       else
 ((LAMBDA (MWORD)
					(if
 (AND NVAL (ZEROP (SETQ NVAL (LOGAND NVAL MASK))))
					    then
             (* Depositing a byte of 0's)

						 MWORD
					  elseif
 (AND NVAL (EQ MASK NVAL))
					    then
             (* Depositing a byte of 1'S)

						 (CONS (QUOTE BITSET)
						       (CDR MWORD))
					  else
 (if
 NVAL
						   then
 (SETQ VAL (LLSH NVAL POS))
						 else
 (SETQ VAL (BQUOTE (LOGAND , VAL , MASK)))
						      (if
 (NOT (ZEROP POS))
							  then
 (SETQ VAL (LIST (QUOTE LLSH)
									       VAL POS))))
					       (BQUOTE (LOGOR , MWORD , VAL))))
				      (BQUOTE (BITCLEAR
 , WORD , (LLSH MASK POS)))))))))
      (EVALUABLE.CONSTANT.FIXP (CADR X))
      (EVALUABLE.CONSTANT.FIXP (CADDR X)))))
)
)
(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 .XUNBOX. MACRO 
((X HX LX)
  (until
 (SETQ LX (SELECTC (NTYPX X)
			   (\SMALLP (COND
				      ((SMALLPOSP X)
					(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 \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 .XLLSH. MACRO 
((HI LO N)
  (if
 (IGEQ N BITSPERWORD)
      then
                                                   (* Jump 10 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 .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 .XLLSH1. MACRO 
((HI LO)
  (PROGN (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 .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))))))

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


(* END EXPORTED DEFINITIONS)

)



(* Some version of the following should be done in MACHINEDEPENDENT for the other Interlisps.)



(RPAQQ \MODLESSPBOX
 NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS \MODLESSPBOX)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY 
(PUTDEF (QUOTE \MODLESSPBOX)
	(QUOTE GLOBALRESOURCES)
	(QUOTE (NCREATE (QUOTE FIXP))))
)
(DEFINEQ

(IMODLESSP

  (LAMBDA (X Y MODULUS EQUAL?)                               (* JonL "21-NOV-82 15:58")

    (if
 (AND EQUAL? (EQ X Y))
	then
                                                 (* Merely a fail-safe heuristic.)

	     T
      elseif
 (OR (EQ MODULUS (QUOTE WORD))
		 (AND (FIXP MODULUS)
		      (IGEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD)))
		      (ILEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD)))))
	then
 (OR (SMALLP (SETQ X (IDIFFERENCE Y X)))
		 (SETQ X (fetch
 (FIXP LONUM) of
 X)))
	     (if
 (ZEROP X)
		 then
 EQUAL?
	       else
 (ILESSP X (CONSTANT (EXPT 2 (SUB1 BITSPERWORD)))))
      elseif
 (OR (EQ MODULUS (QUOTE CELL))
		 (AND (FIXP MODULUS)
		      (POWEROFTWOP MODULUS)))
	then
 ((LAMBDA (TEMPY)
		 (\MOVETOBOX Y TEMPY)
		 (\BOXIDIFFERENCE TEMPY X)
		 (if
 (AND (ZEROP (fetch
 (FIXP HINUM) of
 TEMPY))
			  (ZEROP (fetch
 (FIXP LONUM) of
 TEMPY)))
		     then
 EQUAL?
		   elseif
 (EQ MODULUS (QUOTE CELL))
		     then
 (IGREATERP TEMPY 0)
		   elseif
 (SMALLP MODULUS)
		     then
 (if
 (ZEROP (SETQ X (LOGAND TEMPY (SUB1 MODULUS))))
			      then
 EQUAL?
			    else
 (ILESSP X (LRSH MODULUS 1)))
		   else
 (PROG ((DIV (SUB1 (INTEGERLENGTH MODULUS))))
			      (RETURN (if
 (ZEROP (SETQ X (LOGAND TEMPY (MASK.1'S
 0 DIV))))
					  then
 EQUAL?
					else
 (ILESSP X (MASK.1'S
 (SUB1 DIV)
								 1)))))))
	       (CREATECELL \FIXP))
      else
 (ILESSP (IMOD (DIFFERENCE Y X)
			 MODULUS)
		   (FOLDHI MODULUS 2)))))

(IMODPLUS

  (LAMBDA (X Y MODULUS)                                      (* JonL "21-NOV-82 16:05")

    (PROG NIL
      A   (SELECTC (NTYPX MODULUS)
		   (\LITATOM (SELECTQ MODULUS
				      (WORD (RETURN (.SUMSMALLMOD. (\LONUM X)
								   (\LONUM Y))))
				      (CELL (RETURN ((LAMBDA (\OVERFLOW)
							(IPLUS X Y))
						      0)))
				      NIL))
		   ((LIST \FIXP \SMALLP)
		     (AND (IGREATERP MODULUS 0)
			  (if
 (AND (IGEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD)))
				   (ILEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD))))
			      then
 (SETQ MODULUS (QUOTE WORD))
				   (GO A)
			    else
 (RETURN ((LAMBDA (TEMPX)
					     (\MOVETOBOX X TEMPX)
					     (\BOXIPLUS TEMPX Y)
					     (IMOD TEMPX MODULUS))
					   (CREATECELL \FIXP))))))
		   NIL)
          (SETQ MODULUS (LISPERROR "ILLEGAL ARG" MODULUS T))
          (GO A))))

(IMODDIFFERENCE

  (LAMBDA (X Y MODULUS)                                      (* JonL "21-NOV-82 16:05")

    (PROG NIL
      A   (SELECTC (NTYPX MODULUS)
		   (\LITATOM (SELECTQ MODULUS
				      (WORD (RETURN (.DIFFERENCESMALLMOD. (\LONUM X)
									  (\LONUM Y))))
				      (CELL (RETURN ((LAMBDA (\OVERFLOW)
							(IDIFFERENCE X Y))
						      0)))
				      NIL))
		   ((LIST \FIXP \SMALLP)
		     (AND (IGREATERP MODULUS 0)
			  (if
 (AND (IGEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD)))
				   (ILEQ MODULUS (CONSTANT (EXPT 2 BITSPERWORD))))
			      then
 (SETQ MODULUS (QUOTE WORD))
				   (GO A)
			    else
 (RETURN ((LAMBDA (TEMPX)
					     (\MOVETOBOX X TEMPX)
					     (\BOXIDIFFERENCE TEMPX Y)
					     (IMOD TEMPX MODULUS))
					   (CREATECELL \FIXP))))))
		   NIL)
          (SETQ MODULUS (LISPERROR "ILLEGAL ARG" MODULUS T))
          (GO A))))
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS IMODPLUS DMACRO 
(L
  (PROG ((X (CAR L))
	 (Y (CADR L))
	 (MODULUS (CADDR L)))
        (AND (CONSTANTEXPRESSIONP MODULUS)
	     (EQ (SETQ MODULUS (EVAL MODULUS))
		 (QUOTE CELL))
	     (RETURN (SUBLIS (LIST (CONS (QUOTE X)
					 X)
				   (CONS (QUOTE Y)
					 Y))
			     (QUOTE ((LAMBDA (\OVERFLOW)
					(IPLUS X Y))
				      0)))))
        (RETURN (QUOTE IGNOREMACRO)))))

(PUTPROPS IMODDIFFERENCE DMACRO 
(L
  (PROG ((X (CAR L))
	 (Y (CADR L))
	 (MODULUS (CADDR L)))
        (AND (CONSTANTEXPRESSIONP MODULUS)
	     (EQ (SETQ MODULUS (EVAL MODULUS))
		 (QUOTE CELL))
	     (RETURN (SUBLIS (LIST (CONS (QUOTE X)
					 X)
				   (CONS (QUOTE Y)
					 Y))
			     (QUOTE ((LAMBDA (\OVERFLOW)
					(IDIFFERENCE X Y))
				      0)))))
        (RETURN (QUOTE IGNOREMACRO)))))
)
(DEFINEQ

(ROT

  (LAMBDA (X N FIELDSIZE)                                    (* JonL "29-JAN-83 00:13")

    (SETQ N (\DTEST N (QUOTE SMALLP)))
    (until
 (FIXP X) do
 (SETQ X (LISPERROR "ILLEGAL ARG" X T)))
    (PROG NIL
      A   (if
 (AND (SMALLP FIELDSIZE)
		   (IGREATERP FIELDSIZE 0)
		   (ILEQ FIELDSIZE BITSPERCELL))
	      then
 (SETQ N (IMOD N FIELDSIZE))
		   (RETURN)
	    else
 (SELECTQ FIELDSIZE
			  ((WORD)
			    (SETQ FIELDSIZE BITSPERWORD)
			    (GO A))
			  ((CELL NIL)
			    (SETQ FIELDSIZE BITSPERCELL)
			    (GO A))
			  NIL))
          (SETQ FIELDSIZE (LISPERROR "ILLEGAL ARG" FIELDSIZE T))
          (GO A))

          (* Note that N, the shifting factor, has been normalized into the half-open interval of 0 to FIELDSIZE and a 

	  negative N (rotating rightwards) has been transformed into a positive form.)



    (if
 (EQ N 0)
	then
 X
      else
 (PROG ((N.B (IDIFFERENCE FIELDSIZE N)))
	         (RETURN (if
 (ILEQ FIELDSIZE BITSPERWORD)
			     then
 (SETQ X (LOGAND X (CONSTANT (MASK.1'S
 0 BITSPERWORD))))
				  (\XDEPOSITBYTEWORD
 (\XLOADBYTEWORD
 X N.B N)
						     N N.B X)
			   else
 (DEPOSITBYTE
 (LOADBYTE
 X N.B N)
					     N N.B X)))))))
)
(DECLARE: EVAL@COMPILE 

(PUTPROPS ROT DMACRO 
(L (\ROTexpander L)))
)
(DEFINEQ

(\ROTexpander

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


          (* WARNING! WARNING! Note that the value for BITSPERWORD is bound at the time of compiling this function, and this

	  determines the range of utility of the ROT macro (maybe there is some MAKEINIT problem here?))



    (PROG ((X (CAR L))
	   (N (CADR L))
	   (WORDSIZE (CAR (EVALUABLE.CONSTANTP (CADDR L))))
	   TEM)
          (if
 (AND (OR (FIXP WORDSIZE)
		       (if
 (EQ WORDSIZE (QUOTE WORD))
			   then
 (SETQ WORDSIZE BITSPERWORD)
				T))
		   (SETQ N (EVALUABLE.CONSTANT.FIXP N)))
	      then
 (if
 (SETQ TEM (EVALUABLE.CONSTANT.FIXP X))
		       then
 (RETURN (ROT
 TEM N WORDSIZE))
		     elseif
 (AND (EQ WORDSIZE BITSPERWORD)
				 (EQ 1 N))
		       then
 (RETURN (BQUOTE ((LAMBDA (\Xtested)
						(DECLARE
 (LOCALVARS \Xtested))
						((LAMBDA (\Xbitoff)
						    (DECLARE
 (LOCALVARS \Xbitoff))
						    (if
 (EQ \Xtested \Xbitoff)
							then
 (LLSH \Xbitoff 1)
						      else
 (LOGOR 1 (LLSH \Xbitoff 1))))
						  (LOGAND \Xtested , (MASK.1'S
 0 (SUB1 BITSPERWORD))))
						)
					      (LOGAND , X , (MASK.1'S
 0 BITSPERWORD)))))))
          (RETURN (QUOTE IGNOREMACRO)))))
)



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

(\XLOADBYTE

  (LAMBDA (N POS SIZE)                                       (* JonL "28-OCT-82 22:30")

                                                             (* No error checking)

    (if
 (IGREATERP SIZE BITSPERCELL)
	then
 (SETQ SIZE BITSPERCELL))
    (if
 (IGEQ POS BITSPERCELL)
	then
 0
      else
 (PROG ((M (MASK.1'S
 0 SIZE))
		  NHI NLO MHI MLO)
	         (.XUNBOX. N NHI NLO)
	         (.XUNBOX. M MHI MLO)
	         (.XLRSH. NHI NLO POS)
	         (RETURN (\MAKENUMBER (LOGAND NHI MHI)
				      (LOGAND NLO MLO)))))))

(\XLOADBYTEWORD

  (LAMBDA (N POS SIZE)                                       (* JonL "14-JAN-83 20:33")

                                                             (* N is constrained to be a SMALLP)

    (\MACRO.MX
 (\XLOADBYTEWORD N POS SIZE))))

(\XDEPOSITBYTE

  (LAMBDA (N POS SIZE V)                                     (* JonL "28-OCT-82 22:13")

                                                             (* No error checking but caller MUST certify that 

							     (IGEQ BITSPERCELL (IPLUS POS SIZE)))

    (PROG ((M (MASK.1'S
 POS SIZE))
	   MHI MLO NHI NLO VHI VLO)
          (.XUNBOX. M MHI MLO)
          (.XUNBOX. V VHI VLO)                               (* Move value byte over to correct position, and trim it

							     to size)

          (.XLLSH. VHI VLO POS)
          (SETQ VHI (LOGAND VHI MHI))
          (SETQ VLO (LOGAND VLO MLO))                        (* Cut a "hole" in original number at selected byte)

          (.XUNBOX. N NHI NLO)
          (SETQ NHI (LOGAND NHI (LOGXOR MASKWORD1'S MHI)))
          (SETQ NLO (LOGAND NLO (LOGXOR MASKWORD1'S MLO)))
          (RETURN (\MAKENUMBER (LOGOR NHI VHI)
			       (LOGOR NLO VLO))))))

(\XDEPOSITBYTEWORD

  (LAMBDA (N POS SIZE V EXTENT)                              (* JonL "17-JAN-83 12:15")

                                                             (* N, and result, constrained to be a SMALLP)

                                                             (* No error checking but caller MUST certify that 

							     (IGEQ BITSPERWORD (IPLUS POS SIZE)))

    (if
 (ILESSP BITSPERWORD (OR EXTENT (SETQ EXTENT (IPLUS POS SIZE))))
	then
 (SHOULDNT)
      else
 (PROG ((WORD (BITCLEAR
 N (MASK.1'S
 POS SIZE)))
		  (NEWBYTE (LOGAND V (MASK.1'S
 0 SIZE))))
	         (RETURN (LOGOR WORD (if
 (EQ POS 0)
					 then
                (* Worth optimizing this case)

					      NEWBYTE
				       else
 (\XLLSHWORD
 NEWBYTE POS))))))))

(\XLLSHWORD

  (LAMBDA (N POS)                                            (* JonL " 1-OCT-82 22:47")

                                                             (* Fast Logical Left SHift, where arg and result are 

							     both SMALLP's)

    (if
 (IGEQ POS (CONSTANT BITSPERHALFWORD))
	then
 (SETQ N (LLSH N (CONSTANT BITSPERHALFWORD)))
	     (SETQ POS (IDIFFERENCE POS (CONSTANT BITSPERHALFWORD))))
                                                             (* At this point, POS is strictly less than 8)

    (if
 (IGEQ POS 4)
	then
 (SETQ N (LLSH N 4))
	     (SETQ POS (IDIFFERENCE POS 4)))                 (* At this point, POS is strictly less than 4)

    (if
 (ILESSP POS 2)
	then
 (COND
	       ((ILESSP POS 1)
		 N)
	       (T (LLSH N 1)))
      elseif
 (ILESSP POS 4)
	then
 (COND
	       ((ILESSP POS 3)
		 (LLSH N 2))
	       (T (LLSH N 3)))
      elseif
 (EQP N 0)
	then
 0
      else
                                                   (* (FRPTQ POS (SETQ N (LLSH N 1))))

	   (SHOULDNT))))

(\XLRSHWORD

  (LAMBDA (N POS)                                            (* JonL " 1-OCT-82 22:49")

                                                             (* Fast Logical Right SHift, where arg and result are 

							     both SMALLP's)

    (if
 (IGEQ POS BITSPERWORD)
	then
 0
      else
 (if
 (IGEQ POS (CONSTANT BITSPERHALFWORD))
	       then
 (SETQ N (LRSH N (CONSTANT BITSPERHALFWORD)))
		    (SETQ POS (IDIFFERENCE POS (CONSTANT BITSPERHALFWORD))))
                                                             (* At this point, POS is strictly less than 8)

	   (if
 (IGEQ POS 4)
	       then
 (SETQ N (LRSH N 4))
		    (SETQ POS (IDIFFERENCE POS 4)))          (* At this point, POS is strictly less than 4)

	   (if
 (ILESSP POS 2)
	       then
 (COND
		      ((ILESSP POS 1)
			N)
		      (T (LRSH N 1)))
	     elseif
 (ILESSP POS 4)
	       then
 (COND
		      ((ILESSP POS 3)
			(LRSH N 2))
		      (T (LRSH N 3)))
	     else
                                            (* (FRPTQ POS (SETQ N (LRSH N 1))))

		  (SHOULDNT)))))
)
(DEFINEQ

(\GETBASEBITS

  (LAMBDA (ADDR POSITION SIZE)                               (* JonL "28-OCT-82 22:13")

    (PROG ((WORDNO (FOLDLO POSITION BITSPERWORD))
	   (WSPLIT.BITNO (IMOD POSITION BITSPERWORD))
	   W1 LASTBITNO)
          (SETQ ADDR (\ADDBASE ADDR WORDNO))
          (SETQ W1 (\GETBASE ADDR 0))
          (SETQ LASTBITNO (IPLUS SIZE WSPLIT.BITNO -1))
          (RETURN (COND
		    ((ILESSP LASTBITNO BITSPERWORD)
		      (\XLOADBYTEWORD
 W1 (IDIFFERENCE (CONSTANT (SUB1 BITSPERWORD))
						      LASTBITNO)
				      SIZE))
		    (T (PROG ((NBITS.W1 (IDIFFERENCE BITSPERWORD WSPLIT.BITNO))
			      (W2 (\GETBASE ADDR 1))
			      W1SUBBYTE NW2)
			     (RETURN (COND
				       ((ILEQ SIZE BITSPERWORD)
					 (SETQ NW2 (IDIFFERENCE SIZE NBITS.W1))
                                                             (* NW2 here holds the number of left-justified bits 

							     taken from the second word)

					 (\XDEPOSITBYTEWORD
 (\XLOADBYTEWORD
 W2 (IDIFFERENCE 
										      BITSPERWORD NW2)
									    NW2)
							    NW2 NBITS.W1 W1))
				       ((ILESSP LASTBITNO (CONSTANT (TIMES 2 BITSPERWORD)))
                                                             (* Byte is larger than one word, and is taken from parts

							     of only two words.)

					 (SETQ NW2 (IDIFFERENCE (CONSTANT (SUB1 (TIMES 2 BITSPERWORD))
									  )
								LASTBITNO))
                                                             (* NW2 here is No. of "wasted" bits in word 2)

					 (SETQ W1SUBBYTE (\XLOADBYTEWORD
 W1 NW2 (IDIFFERENCE SIZE 
										      BITSPERWORD)))
					 (.XLRSH. W1 W2 NW2)
                                                             (* Someday, try to replace this .XLRSH.

							     code using LOGOR, \XLLSHWORD and \XLRSHWORD)

					 (\MAKENUMBER W1SUBBYTE W2))
				       (T                    (* Sigh, from parts of three words.)

					  (SETQ NW2 (IDIFFERENCE (CONSTANT (SUB1 (TIMES 3 BITSPERWORD)
										 ))
								 LASTBITNO))
                                                             (* No. of wasted bits on the right of the third word)

					  (SETQ WSPLIT.BITNO (IDIFFERENCE (CONSTANT BITSPERWORD)
									  NW2))
                                                             (* Here WSPLIT.BITNO holds the number of left-justified 

							     bits taken from word 3, and also is relevalt to the 

							     split-up of word 2)

					  (SETQ W1SUBBYTE (\XDEPOSITBYTEWORD

					      (\XLRSHWORD
 W2 NW2)
					      WSPLIT.BITNO
					      (IDIFFERENCE (IPLUS SIZE NW2)
							   (CONSTANT (TIMES 2 BITSPERWORD)))
					      W1))
					  (SETQ W1 (\GETBASE ADDR 2))
                                                             (* W1 now holds "W3", the third word)

					  (.XLLSH. W2 W1 WSPLIT.BITNO)
                                                             (* Someday, try to replace this .XLLSH.

							     using LOGOR, \XLLSHWORD and \XLRSHWORD)

					  (\MAKENUMBER W1SUBBYTE W2)))))))))))

(\PUTBASEBITS

  (LAMBDA (ADDR POSITION SIZE VAL)                           (* JonL "14-OCT-82 10:31")

    (PROG ((WORDNO (FOLDLO POSITION BITSPERWORD))
	   (WSPLIT.BITNO (IMOD POSITION BITSPERWORD))
	   W1 LASTBITNO)
          (SETQ ADDR (\ADDBASE ADDR WORDNO))
          (SETQ W1 (\GETBASE ADDR 0))
          (SETQ LASTBITNO (IPLUS SIZE WSPLIT.BITNO -1))
          (COND
	    ((ILESSP LASTBITNO BITSPERWORD)
	      (\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD
 W1 (IDIFFERENCE (CONSTANT (SUB1 BITSPERWORD))
								  LASTBITNO)
						  SIZE
						  (OR (SMALLP VAL)
						      (\LONUM VAL)))))
	    (T (PROG ((NBITS.W1 (IDIFFERENCE BITSPERWORD WSPLIT.BITNO))
		      (W2 (\GETBASE ADDR 1))
		      NW2 NBITS.W2 VHI VLO)
		     (.XUNBOX. VAL VHI VLO)
		     (COND
		       ((ILEQ SIZE BITSPERWORD)
			 (SETQ NBITS.W2 (IDIFFERENCE SIZE NBITS.W1))
			 (\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD
 W1 0 NBITS.W1 (\XLRSHWORD
 VLO NBITS.W2)))
			 (\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD
 W2 (IDIFFERENCE BITSPERWORD NBITS.W2)
							     NBITS.W2 VLO)))
		       ((ILESSP LASTBITNO (CONSTANT (TIMES 2 BITSPERWORD)))
                                                             (* Byte is larger than one word, and is put into parts 

							     of only two words.)

			 (SETQ NW2 (IDIFFERENCE (CONSTANT (SUB1 (TIMES 2 BITSPERWORD)))
						LASTBITNO))
                                                             (* NW2 here is No. of "wasted" bits in word 2)

			 (SETQ NBITS.W2 (IDIFFERENCE SIZE NBITS.W1))
			 (\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD
 W2 NW2 NBITS.W2 VLO))
			 (SETQ VHI (\XDEPOSITBYTEWORD
 (\XLRSHWORD
 VLO NBITS.W2)
						      NBITS.W2
						      (IDIFFERENCE SIZE BITSPERWORD)
						      VHI))
                                                             (* Foo, do the SETQ only because PP can't hac it 

							     otherwise!)

			 (\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD
 W1 0 NBITS.W1 VHI)))
		       (T                                    (* Sigh, into parts of three words.)

			  (SETQ NW2 (IDIFFERENCE (CONSTANT (SUB1 (TIMES 3 BITSPERWORD)))
						 LASTBITNO))
                                                             (* No. of wasted bits on the right of the third word)

			  (SETQ NBITS.W2 (IDIFFERENCE (CONSTANT BITSPERWORD)
						      NW2))
                                                             (* Here NBITS.W2 holds the number of left-justified bits

							     put into word 3, and also is relevalt to the split-up of

							     word 2)

			  (\PUTBASE ADDR 2 (\XDEPOSITBYTEWORD
 (\GETBASE ADDR 2)
							      NW2 NBITS.W2 VLO))
			  (\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD
 (\XLRSHWORD
 VLO NBITS.W2)
							      NW2 NBITS.W2 VHI))
			  (\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD
 (\GETBASE ADDR 0)
							      0
							      (IDIFFERENCE SIZE (IPLUS BITSPERWORD 
										       NBITS.W2))
							      (\XLRSHWORD
 VHI NBITS.W2)))))))))
    VAL))

(\GETBASEINTEGER

  (LAMBDA (ADDR POSITION SIZE)                               (* JonL "28-OCT-82 22:14")

    (PROG ((WORDNO (FOLDLO POSITION BITSPERWORD))
	   (LOBITNO (IMOD POSITION BITSPERWORD))
	   W1 HIBITNO)
          (SETQ ADDR (\ADDBASE ADDR WORDNO))
          (SETQ W1 (\GETBASE ADDR 0))
          (SETQ HIBITNO (IPLUS SIZE LOBITNO -1))
          (RETURN (COND
		    ((ILESSP HIBITNO BITSPERWORD)
		      (\XLOADBYTEWORD
 W1 LOBITNO SIZE))
		    (T (PROG ((NBITS.W1 (IDIFFERENCE BITSPERWORD LOBITNO))
			      (W2 (\GETBASE ADDR 1))
			      (LOBYTE (IMIN SIZE BITSPERWORD)))
			     (SETQ LOBYTE (\XDEPOSITBYTEWORD
 (\XLRSHWORD
 W1 LOBITNO)
							     NBITS.W1
							     (IDIFFERENCE LOBYTE NBITS.W1)
							     W2))
			     (RETURN (COND
				       ((ILESSP HIBITNO (CONSTANT (TIMES 2 BITSPERWORD)))
                                                             (* Byte comes from at most two words)

					 (COND
					   ((ILEQ SIZE BITSPERWORD)
                                                             (* Byte is not larger than one word, and is taken from 

							     parts of only two words.)

					     LOBYTE)
					   (T (\MAKENUMBER (\XLRSHWORD
 W2 (IDIFFERENCE SIZE 
										      BITSPERWORD))
							   LOBYTE))))
				       (T                    (* Sigh, from parts of three words.)

					  (\MAKENUMBER (\XDEPOSITBYTEWORD

							 (\XLRSHWORD
 W2 LOBITNO)
							 NBITS.W1
							 (IDIFFERENCE HIBITNO
								      (CONSTANT (SUB1 (TIMES 2 
										      BITSPERWORD))))
							 (\GETBASE ADDR 2))
						       LOBYTE)))))))))))

(\PUTBASEINTEGER

  (LAMBDA (ADDR POSITION SIZE VAL)                           (* JonL "14-OCT-82 10:31")

    (PROG ((WORDNO (FOLDLO POSITION BITSPERWORD))
	   (LOBITNO (IMOD POSITION BITSPERWORD))
	   W1 HIBITNO)
          (SETQ ADDR (\ADDBASE ADDR WORDNO))
          (SETQ W1 (\GETBASE ADDR 0))
          (SETQ HIBITNO (IPLUS SIZE LOBITNO -1))
          (COND
	    ((ILESSP HIBITNO BITSPERWORD)
	      (\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD
 W1 LOBITNO SIZE (OR (SMALLP VAL)
								      (\LONUM VAL)))))
	    (T (PROG ((NBITS.W1 (IDIFFERENCE BITSPERWORD LOBITNO))
		      (W2 (\GETBASE ADDR 1))
		      NW2 VHI VLO)
		     (.XUNBOX. VAL VHI VLO)
		     (\PUTBASE ADDR 0 (\XDEPOSITBYTEWORD
 W1 LOBITNO NBITS.W1 VLO))
		     (COND
		       ((ILESSP HIBITNO (CONSTANT (TIMES 2 BITSPERWORD)))
                                                             (* Spread over just two words)

			 (SETQ NW2 (IDIFFERENCE SIZE NBITS.W1))
                                                             (* NW2 here holds the number of right-justified bits put

							     into the second word)

			 (SETQ VLO (\XLRSHWORD
 VLO NBITS.W1))
			 (COND
			   ((IGREATERP SIZE BITSPERWORD)
			     (SETQ VLO (\XDEPOSITBYTEWORD
 VLO (IDIFFERENCE BITSPERWORD NBITS.W1)
							  (IDIFFERENCE SIZE NBITS.W1)
							  VHI))))
			 (\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD
 W2 0 NW2 VLO)))
		       (T                                    (* Sigh, into parts of three words.)

			  (\PUTBASE ADDR 1 (\XDEPOSITBYTEWORD
 (\XLRSHWORD
 VLO NBITS.W1)
							      (IDIFFERENCE BITSPERWORD NBITS.W1)
							      NBITS.W1 VHI))
			  (\PUTBASE ADDR 2 (\XDEPOSITBYTEWORD
 (\GETBASE ADDR 2)
							      0
							      (IDIFFERENCE
								HIBITNO
								(CONSTANT (SUB1 (TIMES 2 BITSPERWORD))
									  ))
							      (\XLRSHWORD
 VHI NBITS.W1)))))))))
    VAL))
)



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


(* FOLLOWING DEFINITIONS EXPORTED)


(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS \GETBASEFLOATP DMACRO 
((BASE OFFST)
  ((LAMBDA (\NewBaseAddr)
      (DECLARE
 (LOCALVARS \NewBaseAddr))
      (create
 FLOATP
	      HIWORD _(\GETBASE \NewBaseAddr 0)
	      LOWORD _(\GETBASE \NewBaseAddr 1)))
    (\ADDBASE BASE OFFST))))

(PUTPROPS \PUTBASEFLOATP DMACRO 
((BASE OFFST VAL)
  ((LAMBDA (\NewBaseAddr \NewVal)
      (DECLARE
 (LOCALVARS \NewBaseAddr \NewVal))
      (OR (FLOATP \NewVal)
	  (\ILLEGAL.ARG \NewVal))
      (\PUTBASE \NewBaseAddr 0 (fetch
 (FLOATP HIWORD) of
 \NewVal))
      (\PUTBASE \NewBaseAddr 1 (fetch
 (FLOATP LOWORD) of
 \NewVal))
      \NewVal)
    (\ADDBASE BASE OFFST)
    VAL)))

(PUTPROPS \GETBASEFIXP DMACRO 
((BASE D)
  ((LAMBDA (\NewBaseAddr)
      (\MAKENUMBER (\GETBASE \NewBaseAddr 0)
		   (\GETBASE \NewBaseAddr 1)))
    (\ADDBASE BASE D))))

(PUTPROPS \PUTBASEFIXP DMACRO 
((BASE OFFST VAL)
                                                             (* JonL "14-OCT-82 11:24")

  ((LAMBDA (\NewBaseAddr \NewVal \HiPart \LoPart)
      (DECLARE
 (LOCALVARS \NewBaseAddr \NewVal \HiPart \LoPart))
      (.XUNBOX. \NewVal \HiPart \LoPart)
      (\PUTBASE \NewBaseAddr 0 \HiPart)
      (\PUTBASE \NewBaseAddr 1 \LoPart)
      \NewVal)
    (\ADDBASE BASE OFFST)
    VAL)))

(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
 (ZEROP (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
 (ZEROP (LOGAND \BitMask \Byte))
	      then
 (NOT (ZEROP VAL))
	    else
 (ZEROP 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

(\GETBASEFLOATP

  (LAMBDA (BASE OFFST)                                       (* JonL " 7-FEB-83 19:41")

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

(\PUTBASEFLOATP

  (LAMBDA (BASE OFFST VAL)                                   (* JonL " 7-FEB-83 19:42")

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

(\GETBASEFIXP

  (LAMBDA (BASE OFFST)                                       (* JonL "19-OCT-82 20:50")

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

(\PUTBASEFIXP

  (LAMBDA (BASE OFFST VAL)                                   (* JonL " 7-FEB-83 20:57")

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

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


(DEFINEQ

(NEWTRUNCATEMULTIPLY

  (LAMBDA (X Y)                                              (* JonL "28-OCT-82 22:14")

                                                             (* 32-bit, unsigned, multiply.

							     Return lower 32 bits)

                                                             (* Must ignore the \OVERFLOW flg -- can be called by 

							     bignum routines wherein the setting of this flg is 

							     random)

    (PROG ((HR 0)
	   (LR 0))
          (.32BITMUL. HR LR X Y)
          (RETURN (\MAKENUMBER HR LR)))))
)
(PUTPROPS ADDARITH COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (3903 4656 (\VectorLENGTH 3913 . 4102) (\MakeVector 4104 . 4250) (\VectorREF 4252 . 4450
) (\VectorSET 4452 . 4654)) (4688 6057 (\SETUP.MASKARRAYS 4698 . 6055)) (7072 7837 (\MASK.1'S.EXPANDER
 7082 . 7835)) (7838 9229 (MASK.1'S 7848 . 8312) (MASK.0'S 8314 . 8667) (BITTEST 8669 . 8812) (BITSET 
8814 . 8955) (BITCLEAR 8957 . 9102) (LOGNOT 9104 . 9227)) (9346 10111 (\MASK.1'S.EXPANDER 9356 . 10109
)) (11451 12467 (LOADBYTE 11461 . 11809) (DEPOSITBYTE 11811 . 12465)) (13338 22254 (\LDBEXPANDER 13348
 . 15175) (\DPBEXPANDER 15177 . 17846) (\LOADBYTEEXPANDER 17848 . 19328) (\DEPOSITBYTEEXPANDER 19330
 . 22252)) (22371 26787 (\LOADBYTEEXPANDER 22381 . 23861) (\DEPOSITBYTEEXPANDER 23863 . 26785)) (32795
 36097 (IMODLESSP 32805 . 34352) (IMODPLUS 34354 . 35211) (IMODDIFFERENCE 35213 . 36095)) (36920 38168
 (ROT 36930 . 38166)) (38245 39529 (\ROTexpander 38255 . 39527)) (39848 44600 (\XLOADBYTE 39858 . 
40419) (\XLOADBYTEWORD 40421 . 40683) (\XDEPOSITBYTE 40685 . 41625) (\XDEPOSITBYTEWORD 41627 . 42425) 
(\XLLSHWORD 42427 . 43494) (\XLRSHWORD 43496 . 44598)) (44601 54048 (\GETBASEBITS 44611 . 47630) (
\PUTBASEBITS 47632 . 50574) (\GETBASEINTEGER 50576 . 52177) (\PUTBASEINTEGER 52179 . 54046)) (57286 
58596 (\GETBASEFLOATP 57296 . 57457) (\PUTBASEFLOATP 57459 . 57624) (\GETBASEFIXP 57626 . 57783) (
\PUTBASEFIXP 57785 . 57946) (\GETBASENIBBLE 57948 . 58109) (\PUTBASENIBBLE 58111 . 58276) (\GETBASEBIT
 58278 . 58433) (\PUTBASEBIT 58435 . 58594)) (58694 59272 (NEWTRUNCATEMULTIPLY 58704 . 59270)))))
STOP