(FILECREATED "19-JUL-83 02:21:11" {PHYLUM}<LISPCORE>SOURCES>ADDARITH.;89 53995 changes to: (VARS ADDARITHCOMS) (MACROS \PUTBASEFIXP) previous date: "24-MAY-83 21:19:31" {PHYLUM}<LISPCORE>SOURCES>ADDARITH.;88) (* Copyright (c) 1982, 1983 by Xerox Corporation) (PRETTYCOMPRINT ADDARITHCOMS) (RPAQQ ADDARITHCOMS ((DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (P (SETQ CLISPIFTRANFLG T))) (LOCALVARS . T) (COMS (* Patch-up for non-D world) (DECLARE: EVAL@COMPILE (P (OR (CONSTANTEXPRESSIONP (QUOTE BITS.PER.FIXP)) (PROGN (SETQ BITS.PER.FIXP (SELECTQ (SYSTEMTYPE) ((TENEX TOPS20) 36) 32)) (CONSTANTS BITS.PER.FIXP))) (OR (BOUNDP (QUOTE \PTRBLOCK.GCT)) (PROGN (SETQ \PTRBLOCK.GCT T) (CONSTANTS (\PTRBLOCK.GCT T))))))) (RECORDS RATIONAL) (COMS (* These facilities should be common with Interlisp-10 and Interlisp-VAX) (MACROS \MakeVector \VectorREF \VectorSET) (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) (EXPORT (DECLARE: DONTCOPY (MACROS \CHECK.BYTESPEC \INDEXABLE.FIXP))) (FNS LOADBYTE DEPOSITBYTE) (RECORDS BYTESPEC) (MACROS LOADBYTE DEPOSITBYTE LDB DPB BYTE BYTESIZE BYTEPOSITION) (FNS \LDBEXPANDER \DPBEXPANDER \LOADBYTEEXPANDER \DEPOSITBYTEEXPANDER)) (COMS (* This entire COMS is for Interlisp-D only) (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) ) (* Patch-up for non-D world) (DECLARE: EVAL@COMPILE (OR (CONSTANTEXPRESSIONP (QUOTE BITS.PER.FIXP)) (PROGN (SETQ BITS.PER.FIXP (SELECTQ (SYSTEMTYPE) ((TENEX TOPS20) 36) 32)) (CONSTANTS BITS.PER.FIXP))) (OR (BOUNDP (QUOTE \PTRBLOCK.GCT)) (PROGN (SETQ \PTRBLOCK.GCT T) (CONSTANTS (\PTRBLOCK.GCT 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) (DECLARE: EVAL@COMPILE (PUTPROPS \MakeVector MACRO ((N) (ARRAY N))) (PUTPROPS \MakeVector DMACRO ((N) (\ALLOCBLOCK N \PTRBLOCK.GCT))) (PUTPROPS \VectorREF MACRO ((V I) (VAG (OPENR (IPLUS (LOC V) I 2))))) (PUTPROPS \VectorREF DMACRO ((V I) (\GETBASEPTR V (LLSH I 1)))) (PUTPROPS \VectorSET MACRO ((V I VAL) (CLOSER (IPLUS (LOC V) I 2) (LOC VAL)) NIL)) (PUTPROPS \VectorSET DMACRO ((V I VAL) (\RPLPTR V (LLSH I 1) VAL))) ) (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))) ) (* FOLLOWING DEFINITIONS EXPORTED) (DECLARE: DONTCOPY (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 "22-JAN-83 15:13") (\CHECK.BYTESPEC POS SIZE) (SELECTQ (SYSTEMTYPE) (D (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)))))) (PROGN (\CHECKTYPE N (FUNCTION FIXP)) (LOGAND (RSH N POS) (MASK.1'S 0 (IMIN BITS.PER.FIXP SIZE))))))) (DEPOSITBYTE (LAMBDA (N POS SIZE VAL) (* JonL "24-OCT-82 18:19") (* Limits set due to BITS.PER.FIXP are because we can't create a BIGNUM answer yet.) (\CHECK.BYTESPEC POS SIZE BITS.PER.FIXP) (SELECTQ (SYSTEMTYPE) (D (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))))) (PROGN (\SIMPLE.CORRECTABLE.TYPECHECK N (QUOTE FIXP)) (LOGOR (BITCLEAR N (MASK.1'S POS SIZE)) (LLSH (LOGAND VAL (MASK.1'S 0 SIZE)) POS)))))) ) [DECLARE: EVAL@COMPILE (TYPERECORD BYTESPEC (BYTESPEC.SIZE BYTESPEC.POSITION)) ] (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 "25-FEB-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 (SELECTQ (SYSTEMTYPE) (D (ILESSP BITSPERWORD (IPLUS POS SIZE))) NIL) 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))))) ) (* This entire COMS is for Interlisp-D only) (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 (4303 5672 (\SETUP.MASKARRAYS 4313 . 5670)) (6687 7452 (\MASK.1'S.EXPANDER 6697 . 7450)) (7453 8844 (MASK.1'S 7463 . 7927) (MASK.0'S 7929 . 8282) (BITTEST 8284 . 8427) (BITSET 8429 . 8570) ( BITCLEAR 8572 . 8717) (LOGNOT 8719 . 8842)) (10060 11460 (LOADBYTE 10070 . 10591) (DEPOSITBYTE 10593 . 11458)) (12418 21375 (\LDBEXPANDER 12428 . 14255) (\DPBEXPANDER 14257 . 16926) (\LOADBYTEEXPANDER 16928 . 18408) (\DEPOSITBYTEEXPANDER 18410 . 21373)) (27434 30736 (IMODLESSP 27444 . 28991) (IMODPLUS 28993 . 29850) (IMODDIFFERENCE 29852 . 30734)) (31559 32807 (ROT 31569 . 32805)) (32884 34168 ( \ROTexpander 32894 . 34166)) (34487 39239 (\XLOADBYTE 34497 . 35058) (\XLOADBYTEWORD 35060 . 35322) ( \XDEPOSITBYTE 35324 . 36264) (\XDEPOSITBYTEWORD 36266 . 37064) (\XLLSHWORD 37066 . 38133) (\XLRSHWORD 38135 . 39237)) (39240 48687 (\GETBASEBITS 39250 . 42269) (\PUTBASEBITS 42271 . 45213) ( \GETBASEINTEGER 45215 . 46816) (\PUTBASEINTEGER 46818 . 48685)) (51925 53235 (\GETBASEFLOATP 51935 . 52096) (\PUTBASEFLOATP 52098 . 52263) (\GETBASEFIXP 52265 . 52422) (\PUTBASEFIXP 52424 . 52585) ( \GETBASENIBBLE 52587 . 52748) (\PUTBASENIBBLE 52750 . 52915) (\GETBASEBIT 52917 . 53072) (\PUTBASEBIT 53074 . 53233)) (53333 53911 (NEWTRUNCATEMULTIPLY 53343 . 53909))))) STOP