add more double-cell numeric primitives and definitions

jumpforth.S

@@ -777,13 +777,6 @@ defcode QDUP,"?DUP"
    push %eax
 1: NEXT
 
-/* ( n -- d ) Convert a single-cell signed integer to a double-cell integer */
-defcode STOD,"S>D"
-   movl (%esp),%eax
-   cltd
-   push %edx
-   NEXT
-
 /* ( a b -- a+b ) */
 defcode ADD,"+"
    pop %eax
@@ -854,28 +847,78 @@ defcode UMMUL,"UM*"
    push %edx
    NEXT
 
-/* ( d1 n1 -- d1%n1 d1/n1 ) Symmetric division (rounds toward zero) and remainder */
+/* ( n -- d ) Convert a single-cell signed integer to a double-cell integer */
-defcode SMDIVREM,"SM/REM"
+defcode STOD,"S>D"
-   pop %ebx
+   movl (%esp),%eax
-   pop %edx
+   cltd
-   pop %eax
-   idivl %ebx
    push %edx
-   push %eax
    NEXT
 
-/* ( ud1 u1 -- ud1%u1 ud1/u1 ) Unsigned division */
+/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell addition */
+defcode DADD,"D+"
+   pop %ebx
+   pop %eax
+   addl %eax,4(%esp)
+   adcl %ebx,(%esp)
+   NEXT
+
+/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell subtraction */
+defcode DSUB,"D-"
+   pop %ebx
+   pop %eax
+   subl %eax,4(%esp)
+   sbbl %ebx,(%esp)
+   NEXT
+
+defcode DNEGATE
+   notl 4(%esp)
+   notl (%esp)
+   addl $1,4(%esp)
+   adcl $0,(%esp)
+   NEXT
+
+/* ( d1 +n1 -- n-remainder d-quotient ) Flooring division with remainder */
+/* NOTE: ANS FORTH has the quotient as a single-cell value (with potential overflow) */
+/* WARNING: This implementation does not handle negative divisors (just dividends) */
+defcode FMDIVMOD,"FM/MOD"
+   pop %ebx  /* divisor */
+   pop %eax  /* upper 32 bits of dividend */
+   cdq
+   idivl %ebx
+   test %edx,%edx
+   jns 0f
+   dec %eax
+   add %ebx,%edx
+0: mov %eax,%ecx
+   pop %eax  /* lower 32 bits of dividend */
+   div %ebx
+   push %edx  /* modulus */
+   push %eax  /* lower 32 bits of quotient */
+   push %ecx  /* upper 32 bits of quotient */
+   NEXT
+
+/* ( ud1 u1 -- u-modulus ud-quotient ) Unsigned division with remainder */
+/* NOTE: ANS FORTH has the quotient as a single-cell value (with potential overflow) */
 defcode UMDIVMOD,"UM/MOD"
    pop %ebx
    pop %edx
-   pop %eax
+   cmp %ebx,%edx
+   jae 1f
+   xor %ecx,%ecx
+0: pop %eax
    divl %ebx
    push %edx
    push %eax
+   push %ecx
    NEXT
+1: mov %edx,%eax
+   xor %edx,%edx
+   divl %ebx
+   mov %eax,%ecx
+   jmp 0b
 
 /* ( n1 n2 n3 -- (n1*n2)%n3 (n1*n2)/n3 ) */
-/* Equivalent to >R M* R> SM/MOD */
+/* Equivalent to >R M* R> SM/MOD S>D */
 /* Note: The intermediate value between multiplication and division is 64 bits */
 defcode MULDIVMOD,"*/MOD"
    pop %ecx
@@ -888,7 +931,7 @@ defcode MULDIVMOD,"*/MOD"
    NEXT
 
 /* Same as MULDIVMOD but for unsigned inputs */
-/* Equivalent to >R UM* R> UM/MOD */
+/* Equivalent to >R UM* R> UM/MOD DROP */
 defcode UMULDIVMOD,"U*/MOD"
    pop %ecx
    pop %ebx
@@ -914,6 +957,16 @@ defcode UTWODIV,"U2/"
    shrl $1,(%esp)
    NEXT
 
+defcode DTWOMUL,"D2*"
+   shll $1,4(%esp)
+   rcll $1,(%esp)
+   NEXT
+
+defcode DTWODIV,"D2/"
+   sarl $1,(%esp)
+   rcrl $1,4(%esp)
+   NEXT
+
 /* ( x1 u -- x2 ) Shift left by u bits */
 defcode LSHIFT
    pop %ecx
@@ -1205,6 +1258,14 @@ defcode LIT
    push %eax
    NEXT
 
+defcode TWOLIT,"2LIT"
+   lodsl
+   mov %eax,%ebx
+   lodsl
+   push %eax
+   push %ebx
+   NEXT
+
 defcode LITSTRING
    xor %eax,%eax
    lodsb

startup.4th

@@ -127,19 +127,22 @@ CREATE THROWN-STRING 0 , 0 ,
 : [ ( -- ) IMMEDIATE FALSE STATE ! ;
 : ] ( -- ) IMMEDIATE TRUE STATE ! ;
 
+\ Convert from a double-cell signed number to a single-cell signed number
+: D>S ( d -- n ) DROP ;
+
 \ Separate the division and modulus operators
-: /MOD  ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> SM/REM ;
+: /MOD  ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> FM/MOD D>S ;
-: /     ( n1 n2 --       n1/n2 ) >R S>D R> SM/REM NIP ;
+: /     ( n1 n2 --       n1/n2 ) >R S>D R> FM/MOD D>S NIP ;
-: MOD   ( n1 n2 -- n1%n2       ) >R S>D R> SM/REM DROP ;
+: MOD   ( n1 n2 -- n1%n2       ) >R S>D R> FM/MOD 2DROP ;
 
 \ Single-cell unsigned division and modulus
-: U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD ;
+: U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD DROP ;
-: U/    ( u1 u2 --       u1/u2 ) 0 SWAP UM/MOD NIP ;
+: U/    ( u1 u2 --       u1/u2 ) 0 SWAP UM/MOD DROP NIP ;
-: UMOD  ( u1 u2 -- u1%u2       ) 0 SWAP UM/MOD DROP ;
+: UMOD  ( u1 u2 -- u1%u2       ) 0 SWAP UM/MOD 2DROP ;
 
-\ Flooring division and modulus (n1%n2 >= 0)
+\ Symmetric division and remainder
-: FM/MOD ( d1 n1 -- d1%n1 d1/n1 )
+: SM/REM ( d1 n1 -- d1%n1 d1/n1 )
-   DUP >R SM/REM OVER 0< IF 1- SWAP R> + SWAP ELSE RDROP THEN ;
+   DUP >R FM/MOD DUP IF OVER 0< IF 1+ SWAP R> - SWAP ELSE RDROP THEN THEN ;
 
 : MIN 2DUP > IF NIP ELSE DROP THEN ;
 : MAX 2DUP < IF NIP ELSE DROP THEN ;
@@ -173,6 +176,15 @@ CREATE THROWN-STRING 0 , 0 ,
 : BYE ( -- <noreturn> )
    BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ;
 
+: D0=  ( xd -- flag ) OR 0= ;
+: D0<> ( xd -- flag ) OR 0<> ;
+: D0<  (  d -- flag ) NIP 0< ;
+: D0>= (  d -- flag ) NIP 0>= ;
+: D0>  (  d -- flag ) DNEGATE NIP 0< ;
+: D0<= (  d -- flag ) DNEGATE NIP 0>= ;
+
+: DABS ( d -- +d ) DUP 0< IF DNEGATE THEN ;
+
 \ Display the unsigned number at the top of the stack
 : U. ( u -- "<digits>" )
    \ Start with the highest place-value on the left
@@ -232,11 +244,14 @@ CREATE THROWN-STRING 0 , 0 ,
    CP !
 ;
 
+\ Allocate one character from the data area and fill it with the value on the stack
+: C, HERE 1 ALLOT C! ;
+
 \ Allocate one cell from the data area and fill it with the value on the stack
 : , HERE CELL ALLOT ! ;
 
-\ Allocate one character from the data area and fill it with the value on the stack
+\ Allocate two cells from the data area and fill them with the values on the stack
-: C, HERE 1 ALLOT C! ;
+: 2, HERE [ 2 CELLS ] LITERAL ALLOT 2! ;
 
 \ Allocate bytes from the data area (less than one cell) to cell-align the address
 : ALIGN HERE ALIGNED HERE - BEGIN ?DUP WHILE 0 C, 1- REPEAT ;
@@ -254,6 +269,9 @@ CREATE THROWN-STRING 0 , 0 ,
 : SLITERAL ( Compilation: c-addr1 u -- ) ( Runtime: -- c-addr2 u ) IMMEDIATE
    POSTPONE LITSTRING DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN ;
 
+: 2LITERAL ( Compilation: x1 x2 -- ) ( Runtime: -- x1 x2 ) IMMEDIATE
+   POSTPONE 2LIT 2, ;
+
 \ Append the execution semantics of the current definition to the current definition
 : RECURSE ( -- ) IMMEDIATE
    LATEST COMPILE, ;
@@ -453,6 +471,17 @@ CREATE CURRENT-SOURCE-ID -1 ,
 : MARK IMMEDIATE WORD POSTPONE SLITERAL POSTPONE (MARK) ;
 ' (MARK) (HIDE)
 
+\ Define a threaded FORTH word
+\ The word is initially hidden so it can refer to a prior word with the same name
+\ The definition is terminated with the ; immediate word, which unhides the name
+: : ( "<spaces>ccc" -- )
+   CREATE LATEST DUP (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ;
+
+\ End a definition by appending EXIT and leaving compilation mode
+\ Unhide the name if it isn't empty (e.g. from :NONAME)
+: ; ( -- ) IMMEDIATE
+   POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ;
+
 \ Define a named constant
 \   Execution: ( value "<spaces>name" -- )
 \   name Execution: ( -- value )
@@ -464,12 +493,18 @@ CREATE CURRENT-SOURCE-ID -1 ,
 \   : CONSTANT : POSTPONE LITERAL POSTPONE ; ;
 : CONSTANT CREATE LATEST >DFA ! ;
 
+\ Same for double-cell constants; no DFA trick this time
+: 2CONSTANT : POSTPONE 2LITERAL POSTPONE ; ;
+
 \ Define a single-cell named variable which returns its data address when executed.
 \ The initial value is formally undefined. This implementation sets it to zero.
 \   Execution: ( "<spaces>name" -- )
 \   name Execution: ( -- a-addr )
 : VARIABLE CREATE 0 , ;
 
+\ Same for double-cell variables (two-variables)
+: 2VARIABLE CREATE [ 0 0 ] 2LITERAL 2, ;
+
 \ Define a single-cell named value which returns its data (not address) when executed.
 \ Named values defined with VALUE can be modified with TO.
 \   Execution: ( x "<spaces>name" -- )
@@ -486,12 +521,6 @@ CREATE CURRENT-SOURCE-ID -1 ,
 : 2ARRAY ( n "<spaces>name" -- )
    CREATE CELLS 2* ALLOT DOES> SWAP [ 2 CELLS ] LITERAL * + ;
 
-\ Define a threaded FORTH word
-\ The word is initially hidden so it can refer to a prior word with the same name
-\ The definition is terminated with the ; immediate word, which unhides the name
-: : ( "<spaces>ccc" -- )
-   CREATE LATEST DUP (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ;
-
 \ Define a threaded word which also displays its name and the data stack when called
 : (TRACE) >NAME TYPE SPACE .DS EOL ;
 : :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ;
@@ -504,11 +533,6 @@ CREATE CURRENT-SOURCE-ID -1 ,
    ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C,
    DUP GET-CURRENT ! ALIGN POSTPONE ] ;
 
-\ End a definition by appending EXIT and leaving compilation mode
-\ Unhide the name if it isn't empty (e.g. from :NONAME)
-: ; ( -- ) IMMEDIATE
-   POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ;
-
 \ Fetch and store the target of the deferred word denoted by deferred-xt
 \ Note that this DEFER! can turn any word into a deferred word
 : DEFER@ ( deferred-xt -- xt ) >DFA @ ;
@@ -1229,21 +1253,23 @@ DEFINITIONS
       DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF
          2DROP RDROP EXIT
       THEN
-      DUP ['] LIT = IF
+      CASE
-         DROP @(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE
+         ['] LIT OF
-      ELSE
+            @(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE
-         DUP ['] LITSTRING = IF
+         ENDOF
-            DROP DUP C@ OVER 1+ OVER
+         ['] 2LIT OF
-            "\"" TYPE TYPE-ESCAPED "\"" TYPE SPACE
+            "[ " TYPE @(+) U. SPACE @(+) . " ] 2LITERAL " TYPE
-            + ALIGNED
+         ENDOF
-         ELSE
+         ['] LITSTRING OF
+            DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED
+         ENDOF
          OVER CELL- NONAME-LITERAL? IF
             DROP DUP @ OVER + 2 CELLS+ DUP R> MAX >R SWAP
             "{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE
          ELSE
             DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF
                >NAME TYPE SPACE
-                  @(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "}" TYPE SPACE
+               @(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "} " TYPE
                OVER CELL- + R> MAX >R
             ELSE
                DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF
@@ -1252,8 +1278,8 @@ DEFINITIONS
                .W SPACE
             THEN
          THEN
-         THEN
+         DUP  \ placeholder to be dropped by ENDCASE since we consumed the xt
-      THEN
+      ENDCASE
    AGAIN ;
 
 HIDE NONAME-LITERAL?
@@ -1261,13 +1287,13 @@ HIDE NONAME-LITERAL?
 : SEE ( "<spaces>name" -- )
    ' DUP >CFA @ CASE
       DOCOL OF
-         ": " TYPE DUP >NAME TYPE
+         ": " TYPE DUP >NAME TYPE " " TYPE
          DUP IMMEDIATE? IF "IMMEDIATE " TYPE THEN
-         " " TYPE >DFA @ UNTHREAD ";\n" TYPE
+         >DFA @ UNTHREAD ";\n" TYPE
       ENDOF
       DODEFER OF
-         "DEFER " TYPE DUP >NAME TYPE " ' " TYPE DUP >DFA @ .W
+         "DEFER " TYPE DUP >NAME TYPE EOL
-            " IS " TYPE >NAME TYPE EOL
+         DUP >DFA @ DUP WORD? IF "' " TYPE .W ELSE U. THEN " IS " TYPE >NAME TYPE EOL
       ENDOF
       DODATA OF
          DUP EXECUTE . " CONSTANT " TYPE >NAME TYPE EOL
@@ -1277,7 +1303,7 @@ HIDE NONAME-LITERAL?
       ENDOF
       DODOES OF
          "CREATE " TYPE DUP >NAME TYPE " … DOES> " TYPE
-         " " TYPE >DFA @ UNTHREAD ";\n" TYPE
+         >DFA @ UNTHREAD ";\n" TYPE
       ENDOF
       \ Anything else can be assumed to be implemented in assembly
       SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE