From: ruvim.pinka@gmail.com   
      
   On 2024-03-27 07:14, Krishna Myneni wrote:   
   > On 3/26/24 17:01, Krishna Myneni wrote:   
   >> Standard source definitions of DLSHIFT and DRSHIFT (double number left   
   >> shift and right shift), over full shift range, per discussion in prior   
   >> thread.   
   >> ...   
   >   
   > This version fixes the issue with the ambiguity of LSHIFT and RSHIFT,   
   > and gives the behavior of DLSHIFT and DRSHIFT which I want. Tests   
   > included below for 32-bit and 64-bit systems.   
   >   
   > --   
   > KM   
   >   
   > === dshift.4th ===   
   > \ dshift.4th   
   > \   
   > \ Source code definitions of DLSHIFT and DRSHIFT   
   >   
   > 1 cells 3 lshift constant BITS_PER_CELL   
   > BITS_PER_CELL 2* constant BITS_PER_DOUBLE   
   >   
   > \ Return the u least significant bits of cell value u1   
   > \ as the most significant bits of u2   
   > : lsbits ( u1 u -- u2 )   
   >       BITS_PER_CELL min   
   >       BITS_PER_CELL - negate   
   >       lshift ;   
   >   
   > \ Return the u most significant bits of cell value u1   
   > \ as the least significant bits of u2   
   > : msbits ( u1 u -- u2 )   
   >       BITS_PER_CELL min   
   >       BITS_PER_CELL - negate   
   >       rshift ;   
   >   
   > 0 value ubits   
   >   
   > \ u is the number of bits to shift   
   >   
   > : DLSHIFT ( ud u -- ud2 )   
   >      dup 0= IF drop EXIT THEN   
   >      BITS_PER_DOUBLE min dup to ubits   
   >      BITS_PER_CELL >= IF   
   >        drop      \ high double has been left shifted out   
   >        ubits BITS_PER_CELL -   
   >        dup BITS_PER_CELL = IF   
   >          2drop 0 0   
   >        ELSE   
   >          lshift 0 swap   
   >        THEN   
   >      ELSE   
   >        ubits lshift swap   
   >        dup >r   
   >        ubits msbits or   
   >        r> ubits lshift   
   >        swap   
   >      THEN ;   
   >   
   > : DRSHIFT ( ud u -- ud2 )   
   >      dup 0= IF drop EXIT THEN   
   >      BITS_PER_DOUBLE min dup to ubits   
   >      BITS_PER_CELL >= IF   
   >        nip    \ low double has been right shifted out   
   >        ubits BITS_PER_CELL -   
   >        dup BITS_PER_CELL = IF   
   >          2drop 0 0   
   >        ELSE   
   >          rshift 0   
   >        THEN   
   >      ELSE   
   >        swap ubits rshift   
   >        swap dup >r   
   >        ubits lsbits or   
   >        r> ubits rshift   
   >      THEN ;   
   >   
   > === End of dshift.4th ===   
      
      
      
      
   I wrote a simpler implementation a long time ago. The file   
   "double-shift.fth" below is a translation from [2] using different names   
   for constants.   
      
      
   === "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"   
      
      
      
   [2] Low-level definition for doubling cell size (in ForthML)   
      
      
   --   
   Ruvim   
      
   --- SoupGate-Win32 v1.05   
    * Origin: you cannot sedate... all the things you hate (1:229/2)