From: the.beez.speaks@gmail.com   
      
   On 27-03-2024 20:49, Krishna Myneni wrote:   
   > On 3/27/24 11:36, Ruvim wrote:   
   >   
   >>>> === "double-shift.fth"   
   >>>>   
   >>>> :NONAME 0 -1 BEGIN DUP WHILE SWAP 1+ SWAP 1 RSHIFT REPEAT DROP ;   
   >>>> EXECUTE   
   >>>> CONSTANT BITS-PER-CELL   
   >>>>   
   >>>> BITS-PER-CELL 1-      CONSTANT MAX-FOR-SHIFT1   
   >>>> BITS-PER-CELL 2* 1-   CONSTANT MAX-FOR-SHIFT2   
   >>>>   
   >>>> : (DLSHIFT) ( xd1 u -- xd2 )   
   >>>>    ( x.lo x.hi  u )   
   >>>>    TUCK LSHIFT >R   
   >>>>    2DUP NEGATE BITS-PER-CELL + RSHIFT >R   
   >>>>    LSHIFT 2R> OR   
   >>>> ;   
   >>>> : DLSHIFT ( xd1 u -- xd2 )   
   >>>>    DUP 0= IF  DROP EXIT THEN   
   >>>>    DUP MAX-FOR-SHIFT2 U> IF  DROP 2DROP 0. EXIT THEN   
   >>>>    DUP MAX-FOR-SHIFT1 U> IF  NIP BITS-PER-CELL - LSHIFT 0 SWAP EXIT   
   >>>> THEN   
   >>>>    (DLSHIFT)   
   >>>> ;   
   >>>> : (DRSHIFT) ( xd1 u -- xd2 )   
   >>>>    ( x.lo x.hi  u )   
   >>>>    2DUP RSHIFT >R   
   >>>>    TUCK NEGATE BITS-PER-CELL + LSHIFT >R   
   >>>>    RSHIFT R> OR R>   
   >>>> ;   
   >>>> : DRSHIFT ( xd1 u -- xd2 )   
   >>>>    DUP 0= IF  DROP EXIT THEN   
   >>>>    DUP MAX-FOR-SHIFT2 U> IF  DROP 2DROP 0. EXIT THEN   
   >>>>    DUP MAX-FOR-SHIFT1 U> IF  >R NIP R> BITS-PER-CELL - RSHIFT 0 EXIT   
   >>>> THEN   
   >>>>    (DRSHIFT)   
   >>>> ;   
   >>>>   
   >>>> === End of "double-shift.fth"   
      
   Can't make it any shorter than this. And no idea what happens with less   
   robust LSHIFT or RSHIFT implementations. CELL-BITS should be most   
   obvious, : SPIN SWAP ROT ; should fix most porting issues, replace ;THEN   
   with EXIT THEN. It passes all tests.   
      
   : dlshift   
      dup 0> 0= if drop ;then   
      >r over 0 invert cell-bits r@ - dup >r lshift and r> rshift swap   
      r@ lshift or swap r> lshift swap   
      
      
   : drshift   
      dup 0> 0= if drop ;then   
      >r dup 0 invert cell-bits r@ - dup >r rshift and r> lshift swap   
      r@ rshift spin r> rshift or swap   
      
      
   Hans Bezemer   
      
   --- SoupGate-Win32 v1.05   
    * Origin: you cannot sedate... all the things you hate (1:229/2)