(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")(filecreated " 4-Nov-86 13:21:14" {eris}<lispcore>sources>addarith.\;27 34131        |changes| |to:|  (vars addarithcoms)      |previous| |date:| " 3-Nov-86 11:55:32" {eris}<lispcore>sources>addarith.\;26); Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation.  All rights reserved.(prettycomprint addarithcoms)(rpaqq addarithcoms ((localvars . t)                     (* \; "OK")                     (macros mask.1\'s mask.0\'s bittest bitset bitclear)                     (coms (optimizers lognot)                           (fns lognot))                     (coms (* \; "BYTE hacking functions")                           (records bytespec)                           (macros loadbyte depositbyte)                           (* \; "NOT OK YET")                           (optimizers byte dpb ldb)                           (macros bytesize byteposition)                           (fns ldb dpb byte)                           (fns \\ldbexpander \\dpbexpander))                     (coms (optimizers imod)                           (fns imodlessp)                           (macros imodplus imoddifference))                     (coms (fns rot)                           (macros .rot.))                     (coms (* |;;| "Primitive Functions for extracting fields as integers")                           (macros \\xloadbyteword)                           (fns \\putbasebits)                           (* |;;|                               "Primitive functions, especially needed for CommonLisp array package.")                           (declare\: dontcopy (macros .hihalfwordlo. .hihalfwordhi. .lohalfwordlo.                                                       .lohalfwordhi.)))                     (coms (* |;;|                "Beginning of rewrite of some LLARITH things, modularly using the macros of this file"                              )                           (declare\: dontcopy (export (constants mask0word1\'s mask1word0\'s                                                               maskword1\'s maskhalfword1\'s                                                               bitsperhalfword)                                                      (macros eqzerop)                                                      (macros \\movetobox .xunbox. .xllsh. .xllsh1.                                                              .xlrsh. .add.2word.integers.                                                              .sub.2word.integers. .32bitmul.)                                                      (macros .sumsmallmod. .differencesmallmod.))                                  (macros .add.2word.integers. .sub.2word.integers. .32bitmul.)                                  (macros \\getbasenibble \\putbasenibble \\getbasebit \\putbasebit))                           )                     (prop filetype addarith)))(declare\: doeval@compile dontcopy(localvars . t))(* \; "OK")(declare\: eval@compile (putprops mask.1\'s macro (openlambda (position size)                                 (lsh (sub1 (lsh 1 size))                                      position)))(putprops mask.0\'s macro (openlambda (position size)                                 (lognot (mask.1\'s position size))))(putprops bittest macro ((n mask)                         (neq 0 (logand n mask))))(putprops bitset macro (= . logor))(putprops bitclear macro ((x mask)                          (logand x (lognot mask)))))(defoptimizer lognot (integer)       `(logxor -1 ,integer))(defineq(lognot  (lambda (integer)                                          (* |kbr:| "12-Jul-86 17:05")    (logxor -1 integer))))(* \; "BYTE hacking functions")(declare\: eval@compile(typerecord bytespec (bytespec.size bytespec.position)))(declare\: eval@compile (putprops loadbyte macro ((n pos size)                          (logand (rsh n pos)                                 (mask.1\'s 0 size))))(putprops depositbyte macro (openlambda (n pos size val)                                   (logor (bitclear n (mask.1\'s pos size))                                          (lsh (logand val (mask.1\'s 0 size))                                               pos)))))(* \; "NOT OK YET")(defoptimizer byte (&rest x)       (prog ((size (lispform.simplify (car x)                           t))              (position (lispform.simplify (cadr x)                               t)))             (return (cond ((and (fixp position)                                 (fixp size))                            (kwote (|create| bytespec bytespec.size _ size bytespec.position _                                           position)))                           (t `(|create| bytespec bytespec.size _ ,size bytespec.position _                                      ,position))))))(defoptimizer dpb (&rest x)       (\\dpbexpander x))(defoptimizer ldb (&rest x)       (\\ldbexpander x))(declare\: eval@compile (putprops bytesize macro ((bytespec)                          (|fetch| bytespec.size |of| bytespec)))(putprops byteposition macro ((bytespec)                              (|fetch| bytespec.position |of| bytespec))))(defineq(ldb  (lambda (bytespec integer)                                 (* |kbr:| "12-Jul-86 17:10")    (loadbyte integer (|fetch| (bytespec bytespec.position) |of| bytespec)           (|fetch| (bytespec bytespec.size) |of| bytespec))))(dpb  (lambda (newbyte bytespec integer)                         (* |kbr:| "12-Jul-86 17:18")    (depositbyte integer (|fetch| (bytespec bytespec.position) |of| bytespec)           (|fetch| (bytespec bytespec.size) |of| bytespec)           newbyte)))(byte  (lambda (size position)                                    (* |kbr:| "14-Aug-86 14:18")    (|create| bytespec           bytespec.size _ size           bytespec.position _ position))))(defineq(\\ldbexpander  (lambda (x)                                                (* |kbr:| "14-Aug-86 14:27")    (prog (bs word tem n size position)                      (* x = (bytespec integer) *)          (setq bs (lispform.simplify (car x)                          t))          (setq word (cadr x))          (return (cond                     ((and (setq tem (car (evaluable.constantp bs)))                           (|type?| bytespec tem))                      (list 'loadbyte word (kwote (byteposition tem))                            (kwote (bytesize tem))))                     (t (setq n (lispform.simplify word t))                        (cond                           ((and (listp bs)                                 (eq (car bs)                                     'byte))                            (setq size (cadr bs))                            (setq position (caddr bs))                            (cond                               ((or (evaluable.constant.fixp n)                                    (and (args.commutablep n size)                                         (args.commutablep n position)                                         (args.commutablep size position)))                                `(loadbyte ,word ,position ,size))                               (t `((lambda (|\\Bytesize| |\\Byteposition|)                                      (declare (localvars |\\Bytesize| |\\Byteposition|))                                      (loadbyte \, word |\\Byteposition| |\\Bytesize|))                                    \, size \, position))))                           ((and (litatom bs)                                 (or (evaluable.constant.fixp n)                                     (args.commutablep bs n)))                            `(loadbyte \, word (byteposition \, bs)                                    (bytesize \, bs)))                           (t `((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)                         'cons)                     (equal (cadr bs)                            ''bytespec)                     (listp (setq tem (caddr bs)))                     (eq (car tem)                         '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| '|\\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|)                               `(depositbyte \, word \, pos \, size \, byteform)                       |else| `((lambda (|\\Bytesize| |\\Byteposition|)                                  (declare (localvars |\\Bytesize| |\\Byteposition|))                                  (depositbyte \, word |\\Byteposition| |\\Bytesize| \, byteform))                                \, size \, pos))             |else| (|if| (and (litatom bs)                               (args.commutablep word bs))                        |then| `(depositbyte \, word (byteposition \, bs)                                       (bytesize \, bs)                                       \, byteform)                      |else| (setq |BagBiterP| t)                            `((lambda (|\\ByteSpec|)                                (declare (localvars |\\ByteSpec|))                                (depositbyte \, word (byteposition |\\ByteSpec|)                                       (bytesize |\\ByteSpec|)                                       |\\NewByte|))                              \, bs))))          (return (|if| |BagBiterP|                      |then| `((lambda (|\\NewByte|)                                 (declare (localvars |\\NewByte|))                                 \, depositform)                               \, newbyte)                    |else| depositform))))))(defoptimizer imod (&rest l)       (prog ((n (constantexpressionp (cadr l))))             (|if| (null n)                   |then|                   (return 'ignoremacro))             (setq n (car n))             (return (cond ((not (poweroftwop n))                            'ignoremacro)                           (t (list 'logand (car l)                                    (sub1 n)))))))(defineq(imodlessp  (lambda (x y modulus)                                      (* |lmm| "12-Apr-85 12:43")    (ilessp (imoddifference y x modulus)           (foldhi modulus 2)))))(declare\: eval@compile (putprops imodplus macro ((x y modulus)                          (imod (iplus x y)                                modulus)))(putprops imoddifference macro ((x y modulus)                                (imod (idifference x y)                                      modulus))))(defineq(rot  (lambda (x n fieldsize)                                    (* |Pavel| " 7-Oct-86 15:26")                                                  (* |;;| "Normalize N, the shift factor, into the half-open interval of 0 to FIELDSIZE and transform a negative N (rotating rightwards) into a positive form.")    (let* ((n (imod n fieldsize))           (n.b (idifference fieldsize n)))          (depositbyte (loadbyte x n.b n)                 n n.b x)))))(declare\: eval@compile (putprops .rot. macro ((xform n fieldsize)                       ((openlambda (x)                               (depositbyte (loadbyte x (idifference fieldsize n)                                                   n)                                      n                                      (idifference fieldsize n)                                      x))                        xform))))(* |;;| "Primitive Functions for extracting fields as integers")(declare\: eval@compile (putprops \\xloadbyteword dmacro ((n pos size)                                  (* n |is| |constrained| |to| |be| \a smallp)                                  (logand (\\xlrshword n pos)                                         (mask.1\'s 0 (imin bitsperword size))))))(defineq(\\putbasebits  (lambda (addr position size val)                           (* |lmm| "12-Apr-85 15:18")    (|if| (greaterp position bitsperword)        |then| (\\putbasebits (\\addbase addr (foldlo position bitsperword))                      (imod position bitsperword)                      size val)      |elseif| (greaterp size (difference bitsperword position))        |then|                                               (* |more| |than| |one| |word|)              (\\putbasebits addr position (difference bitsperword position)                     (rsh val (setq size (difference size (difference bitsperword position)))))              (\\putbasebits (\\addbase addr 1)                     0 size val)      |else|                                                 (* \a |single| |word|)            (\\putbase addr 0 (depositbyte (\\getbase addr 0)                                     (difference (sub1 bitsperword)                                            position)                                     size val))))))(* |;;| "Primitive functions, especially needed for CommonLisp array package.")(declare\: dontcopy (declare\: eval@compile (putprops .hihalfwordlo. macro ((x)                                (lrsh x bitsperhalfword)))(putprops .hihalfwordhi. macro ((x)                                (logand x (constant (lsh maskhalfword1\'s bitsperhalfword)))))(putprops .lohalfwordlo. macro ((x)                                (logand x maskhalfword1\'s)))(putprops .lohalfwordhi. macro ((x)                                (llsh (logand x maskhalfword1\'s)                                      bitsperhalfword)))))(* |;;| "Beginning of rewrite of some LLARITH things, modularly using the macros of this file")(declare\: dontcopy (* "FOLLOWING DEFINITIONS EXPORTED")(declare\: eval@compile (rpaqq mask0word1\'s 32767)(rpaqq mask1word0\'s 32768)(rpaqq maskword1\'s 65535)(rpaqq maskhalfword1\'s 255)(rpaqq bitsperhalfword 8)(constants mask0word1\'s mask1word0\'s maskword1\'s maskhalfword1\'s bitsperhalfword))(declare\: eval@compile (putprops eqzerop macro ((x)                         (eq 0 x))))(declare\: eval@compile (putprops \\movetobox dmacro (openlambda (n d)                                    (selectc (ntypx n)                                           (\\smallp (|replace| (fixp hinum)                                                            |of| d |with| 0)                                                  (|replace| (fixp lonum)                                                         |of| d |with| n))                                           (\\fixp (|replace| (fixp hinum)                                                          |of| d |with| (|fetch| (fixp hinum)                                                                               |of| n))                                                  (|replace| (fixp lonum)                                                         |of| d |with| (|fetch| (fixp lonum)                                                                              |of| n)))                                           (\\illegal.arg n))))(putprops .xunbox. macro ((x hx lx)                          (|until| (setq lx (selectc (ntypx x)                                                   (\\smallp (cond ((igeq x 0)                                                                    (setq hx 0)                                                                    x)                                                                   (t (setq hx maskword1\'s)                                                                      (\\loloc x))))                                                   (\\fixp (setq hx (|fetch| (fixp hinum)                                                                           |of| x))                                                          (|fetch| (fixp lonum)                                                                 |of| x))                                                   nil))                                 |do|                                 (setq x (lisperror "ILLEGAL ARG" x t)))))(putprops .xllsh. macro ((hi lo n)                         (|if| (igeq n bitsperword)                               |then|                               (* |Jump| 16 |bits| |in| \a |single| |bound!|)                               (setq hi lo)                               (setq lo 0)                               (setq n (idifference n bitsperword)))                         (|if| (igeq n bitsperhalfword)                               |then|                               (* |Jump| 8 |bits| |in| \a |single| |bound!|)                               (setq hi (logor (.lohalfwordhi. hi)                                               (.hihalfwordlo. lo)))                               (setq lo (.lohalfwordhi. lo))                               (setq n (idifference n bitsperhalfword)))                         (|if| (igeq n 4)                               |then|                               (* |Jump| 4 |bits| |in| \a |single| |bound!|)                               (setq hi (logor (lrsh lo (constant (idifference bitsperword 4)))                                               (llsh (logand hi (constant (mask.1\'s 0                                                                                 (idifference                                                                                         bitsperword 4                                                                                        ))))                                                     4)))                               (setq lo (llsh (logand lo (constant (mask.1\'s 0 (idifference                                                                                        bitsperword 4)                                                                          )))                                              4))                               (setq n (idifference n 4)))                         (* mask0word1\'s |should| |be| |same| |as| (sub1 (lsh 1 (sub1 bitsperword)))                            )                         (frptq n (setq hi (llsh (logand hi mask0word1\'s)                                                 1))                                (setq lo (llsh (|if| (igeq lo mask1word0\'s)                                                     |then|                                                     (|add| hi 1)                                                     (logand lo mask0word1\'s)                                                     |else| lo)                                               1)))))(putprops .xllsh1. macro ((hi lo)                          (setq hi (llsh (logand hi mask0word1\'s)                                         1))                          (setq lo (lsh (cond ((igeq lo mask1word0\'s)                                               (setq hi (logor hi 1))                                               (logand lo mask0word1\'s))                                              (t lo))                                        1))))(putprops .xlrsh. macro ((hi lo n)                         (|if| (igeq n bitsperword)                               |then|                               (* |Jump| 10 |bits| |in| \a |single| |bound!|)                               (setq lo hi)                               (setq hi 0)                               (setq n (idifference n bitsperword)))                         (|if| (igeq n bitsperhalfword)                               |then|                               (* |Jump| 8 |bits| |in| \a |single| |bound!|)                               (setq lo (logor (.hihalfwordlo. lo)                                               (.lohalfwordhi. hi)))                               (setq hi (.hihalfwordlo. hi))                               (setq n (idifference n bitsperhalfword)))                         (|if| (igeq n 4)                               |then|                               (* |Jump| 4 |bits| |in| \a |single| |bound!|)                               (setq lo (logor (llsh (logand hi (constant (mask.1\'s 0 4)))                                                     (constant (idifference bitsperword 4)))                                               (lrsh lo 4)))                               (setq hi (lrsh hi 4))                               (setq n (idifference n 4)))                         (* mask1word0\'s |should| |be| |same| |as| \\signbit)                         (frptq n (setq lo (|if| (oddp hi)                                                 |then|                                                 (logor (lrsh lo 1)                                                        mask1word0\'s)                                                 |else|                                                 (lrsh lo 1)))                                (setq hi (lrsh hi 1)))))(putprops .add.2word.integers. macro ((hx lx hy ly)                                      (* |Ignores| |carry| |out| |of| |high-order| |word|)                                      (setq hx (.sumsmallmod. hx hy))                                      (setq lx (.sumsmallmod. lx ly (setq hx                                                                          (|if| (eq hx                                                                                     max.small.integer                                                                                    )                                                                                |then| 0 |else|                                                                                (add1 hx)))))))(putprops .sub.2word.integers. macro ((hx lx hy ly)                                      (* |Ignores| |carry| |out| |of| |high-order| |word|)                                      (setq hx (.differencesmallmod. hx hy))                                      (setq lx (.differencesmallmod. lx ly                                                      (setq hx (|if| (eq hx 0)                                                                     |then| max.small.integer |else|                                                                     (sub1 hx)))))))(putprops .32bitmul. macro ((hr lr x y)                            (prog (hx lx hy ly)                                  (|if| (ilessp x y)                                        |then|                                        (|swap| x y))                                  (* y |is| |the| |lesser| |of| |the| |two| |now|)                                  (.xunbox. x hx lx)                                  (.xunbox. y hy ly)                                  lp                                  (|if| (oddp ly)                                        |then|                                        (.add.2word.integers. hr lr hx lx))                                  (|if| (eq hy 0)                                        |then|                                        (setq ly (lrsh ly 1))                                        (|if| (eq ly 0)                                              |then|                                              (return))                                        |else|                                        (.lrsh1. hy ly))                                  (* |Trim| |off| |highest| |bits,| |so| |that| |left-shifting|                                      |doesn't| |generate| fixp\s)                                  (setq hx (logand hx mask0word1\'s))                                  (.llsh1. hx lx)                                  (go lp)))))(declare\: eval@compile (putprops .sumsmallmod. macro ((x y overflowform)                               ((lambda (|\\SumSmallModVar|)                                       (declare (localvars |\\SumSmallModVar|))                                       (if (ileq x |\\SumSmallModVar|)                                           then                                           (iplus x y)                                           else overflowform (idifference x (add1 |\\SumSmallModVar|)                                                                    )))                                (idifference max.small.integer y))))(putprops .differencesmallmod. macro ((x y borrowform)                                      (if (not (igreaterp y x))                                          then                                          (idifference x y)                                          else borrowform (add1 (idifference max.small.integer                                                                       (idifference y x)))))))(* "END EXPORTED DEFINITIONS")(declare\: eval@compile (putprops .add.2word.integers. macro ((hx lx hy ly)                                      (* |Ignores| |carry| |out| |of| |high-order| |word|)                                      (setq hx (.sumsmallmod. hx hy))                                      (setq lx (.sumsmallmod. lx ly (setq hx                                                                          (|if| (eq hx                                                                                     max.small.integer                                                                                    )                                                                                |then| 0 |else|                                                                                (add1 hx)))))))(putprops .sub.2word.integers. macro ((hx lx hy ly)                                      (* |Ignores| |carry| |out| |of| |high-order| |word|)                                      (setq hx (.differencesmallmod. hx hy))                                      (setq lx (.differencesmallmod. lx ly                                                      (setq hx (|if| (eq hx 0)                                                                     |then| max.small.integer |else|                                                                     (sub1 hx)))))))(putprops .32bitmul. macro ((hr lr x y)                            (prog (hx lx hy ly)                                  (|if| (ilessp x y)                                        |then|                                        (|swap| x y))                                  (* y |is| |the| |lesser| |of| |the| |two| |now|)                                  (.xunbox. x hx lx)                                  (.xunbox. y hy ly)                                  lp                                  (|if| (oddp ly)                                        |then|                                        (.add.2word.integers. hr lr hx lx))                                  (|if| (eq hy 0)                                        |then|                                        (setq ly (lrsh ly 1))                                        (|if| (eq ly 0)                                              |then|                                              (return))                                        |else|                                        (.lrsh1. hy ly))                                  (* |Trim| |off| |highest| |bits,| |so| |that| |left-shifting|                                      |doesn't| |generate| fixp\s)                                  (setq hx (logand hx mask0word1\'s))                                  (.llsh1. hx lx)                                  (go lp)))))(declare\: eval@compile (putprops \\getbasenibble dmacro (openlambda (base offst)                                        ((lambda (|\\Byte|)                                                (declare (localvars |\\Byte|))                                                (|if| (oddp offst)                                                      |then|                                                      (logand |\\Byte| (constant (mask.1\'s 0                                                                                         bitspernibble                                                                                        )))                                                      |else|                                                      (lrsh |\\Byte| bitspernibble)))                                         (\\getbasebyte base (foldlo offst nibblesperbyte)))))(putprops \\putbasenibble dmacro       (openlambda (base offst val)              ((lambda (|\\ByteNo|)                      (declare (localvars |\\ByteNo|))                      ((lambda (|\\Byte|)                              (declare (localvars |\\Byte|))                              (\\putbasebyte base |\\ByteNo|                                     (|if| (oddp offst)                                           |then|                                           (logor (logand |\\Byte| (constant (mask.1\'s bitspernibble                                                                                     bitspernibble)))                                                  val)                                           |else|                                           (logor (logand |\\Byte| (constant (mask.1\'s 0                                                                                     bitspernibble)))                                                  (llsh val bitspernibble)))))                       (\\getbasebyte base |\\ByteNo|)))               (foldlo offst nibblesperbyte))))(putprops \\getbasebit dmacro (openlambda (base offst)                                     ((lambda (|\\ByteNo| |\\BitMask|)                                             (declare (localvars |\\ByteNo| |\\BitMask|))                                             (|if| (eq 0 (logand |\\BitMask| (\\getbasebyte base                                                                                     |\\ByteNo|)))                                                   |then| 0 |else| 1))                                      (foldlo offst bitsperbyte)                                      (mask.1\'s (idifference (constant (sub1 bitsperbyte))                                                        (imod offst bitsperbyte))                                             1))))(putprops \\putbasebit dmacro (openlambda (base offst val)                                     ((lambda (|\\ByteNo| |\\BitMask| |\\Byte|)                                             (declare (localvars |\\ByteNo| |\\BitMask| |\\Byte|))                                             (setq |\\Byte| (\\getbasebyte base |\\ByteNo|))                                             (|if| (|if| (eq 0 (logand |\\BitMask| |\\Byte|))                                                         |then|                                                         (not (eq 0 val))                                                         |else|                                                         (eq 0 val))                                                   |then|                                                   (\\putbasebyte base |\\ByteNo| (logxor |\\BitMask|                                                                                          |\\Byte|)))                                             val)                                      (foldlo offst bitsperbyte)                                      (mask.1\'s (idifference (constant (sub1 bitsperbyte))                                                        (imod offst bitsperbyte))                                             1))))))(putprops addarith filetype cl:compile-file)(putprops addarith copyright ("Xerox Corporation" 1982 1983 1984 1985 1986))(declare\: dontcopy  (filemap (nil (3617 3756 (lognot 3627 . 3754)) (5287 6030 (ldb 5297 . 5549) (dpb 5551 . 5825) (byte 5827 . 6028)) (6031 12134 (\\ldbexpander 6041 . 8279) (\\dpbexpander 8281 . 12132)) (12535 12724 (imodlessp 12545 . 12722)) (13031 13500 (rot 13041 . 13498)) (14298 15380 (\\putbasebits 14308 . 15378)))))stop