From: krishna.myneni@ccreweb.org   
      
   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 ===   
      
   Test Code   
      
   === dshift-test.4th ===   
   \ dshift-test.4th   
   \   
   include ans-words \ <-- only for kForth   
   include ttester   
   include dshift   
      
   HEX   
      
   TESTING DLSHIFT DRSHIFT   
      
   t{ 03  01  BITS_PER_CELL   dlshift -> 00 03 }t   
   t{ FF  00  BITS_PER_CELL   dlshift -> 00 FF }t   
   t{ 00  01  BITS_PER_CELL   drshift -> 01 00 }t   
   t{ 00  FF  BITS_PER_CELL   drshift -> FF 00 }t   
   t{ -1  -1  BITS_PER_DOUBLE dlshift -> 00 00 }t   
   t{ -1  -1  BITS_PER_DOUBLE drshift -> 00 00 }t   
      
   BITS_PER_CELL 20 = [IF]   
   t{ 03 01 BITS_PER_CELL 1- dlshift -> 80000000 80000001 }t   
   t{ 80000000 02 1          dlshift -> 00 05 }t   
   t{ 07  03  1              drshift -> 80000003 01 }t   
   [THEN]   
      
   BITS_PER_CELL 40 = [IF]   
   t{ 03 01 BITS_PER_CELL 1- dlshift -> 8000000000000000 8000000000000001 }t   
   t{ 8000000000000000 02 1  dlshift -> 00 05 }t   
   t{ 07  03  1              drshift -> 8000000000000003 01 }t   
   [THEN]   
      
   DECIMAL   
      
   === end of dshift-test.4th ===   
      
   --- SoupGate-Win32 v1.05   
    * Origin: you cannot sedate... all the things you hate (1:229/2)