add more primitives from the ANS FORTH standard

jumpforth.S

@@ -80,7 +80,7 @@ DODATA:
    pushl 4(%eax)
    NEXT
 
-/* The default behavior for words defined with VALUE (or defparam) */
+/* The default behavior for words defined with VALUE (or defvalue) */
 /* Load the word at the address in the DFA field and place it on the stack */
    .text
    .align 4
@@ -173,7 +173,7 @@ defname \label,DODATA,\value,"\name",\flags
 
 /* Parameters are stored like variables but produce a value, not an address. */
 /* Use this for data which is read-only after initialization. */
-.macro defparam label:req,initial=0,name="",flags=0
+.macro defvalue label:req,initial=0,name="",flags=0
 defname \label,DOLOAD,data_\label,"\name",\flags
    .data
    .align 4
@@ -613,8 +613,8 @@ defconst SIGABRT,6
 /* defconst __O_NONBLOCK,04000,"O_NONBLOCK" */
 
 /* NOTE: These are initialized in _start and read-only thereafter. */
-defparam C0     /* first byte of the heap */
+defvalue C0     /* first byte of the heap */
-defparam S0     /* initial (empty) data stack pointer */
+defvalue S0     /* initial (empty) data stack pointer */
 
 /* STATE controls whether we are currently executing code (0) or compiling (1) */
 defvar STATE,0  /* default to executing code */
@@ -751,6 +751,20 @@ defcode PICK
    pushl (%esp,%eax,4)
    NEXT
 
+/* ( xu ... x0 u -- xu-1 ... x0 xu ) */
+defcode ROLL
+   pop %ecx
+   movl (%esp,%ecx,4),%ebx
+   mov %esi,%edx
+   lea -4(%esp,%ecx,4),%esi
+   lea (%esp,%ecx,4),%edi
+   std
+   rep movsd
+   cld
+   mov %edx,%esi
+   movl %ebx,(%esp)
+   NEXT
+
 /* ( 0 -- 0 ) */
 /* ( a -- a a ) */
 defcode QDUP,"?DUP"
@@ -760,6 +774,13 @@ 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
@@ -782,10 +803,20 @@ defcode SUB1,"1-"
    decl (%esp)
    NEXT
 
+/* ( x1 -- x2 ) Two's complement of x1 */
 defcode NEGATE
    negl (%esp)
    NEXT
 
+/* ( n -- u ) Absolute value */
+defcode ABS
+   pop %eax
+   test %eax,%eax
+   jl 0f
+   neg %eax
+0: push %eax
+   NEXT
+
 /* ( n1 n2 -- n1*n2 ) ( ignores overflow ) */
 defcode MUL,"*"
    pop %eax
@@ -794,6 +825,15 @@ defcode MUL,"*"
    push %eax
    NEXT
 
+/* ( n1 n2 -- d ) Multiply, producting a double-cell result */
+defcode MMUL,"M*"
+   pop %eax
+   pop %ebx
+   imull %ebx,%eax
+   push %eax
+   push %edx
+   NEXT
+
 /* ( u1 u2 -- u1*u2 ) ( ignores overflow ) */
 defcode UMUL,"U*"
    pop %eax
@@ -802,26 +842,87 @@ defcode UMUL,"U*"
    push %eax
    NEXT
 
-/* ( n1 n2 -- n1%n2 n1/n2 ) */
+/* ( u1 u2 -- ud ) Multiply unsigned, producting a double-cell result */
-defcode DIVMOD,"/MOD"
+defcode UMMUL,"UM*"
-   pop %ebx
+   pop %eax
+   pop %ebx
+   mull %ebx
+   push %eax
+   push %edx
+   NEXT
+
+/* ( d1 n1 -- d1%n1 d1/n1 ) Symmetric division (rounds toward zero) and remainder */
+defcode SMDIVREM,"SM/REM"
+   pop %ebx
+   pop %edx
    pop %eax
-   cltd
    idivl %ebx
    push %edx
    push %eax
    NEXT
 
-/* ( u1 u2 -- u1%u2 u1/u2 ) */
+/* ( ud1 u1 -- ud1%u1 ud1/u1 ) Unsigned division */
-defcode UDIVMOD,"U/MOD"
+defcode UMDIVMOD,"UM/MOD"
-   xor %edx,%edx
    pop %ebx
+   pop %edx
    pop %eax
    divl %ebx
    push %edx
    push %eax
    NEXT
 
+/* ( n1 n2 n3 -- (n1*n2)%n3 (n1*n2)/n3 ) */
+/* Equivalent to >R M* R> SM/MOD */
+/* Note: The intermediate value between multiplication and division is 64 bits */
+defcode MULDIVMOD,"*/MOD"
+   pop %ecx
+   pop %ebx
+   pop %eax
+   imull %ebx
+   idivl %ecx
+   push %edx
+   push %eax
+   NEXT
+
+/* Same as MULDIVMOD but for unsigned inputs */
+/* Equivalent to >R UM* R> UM/MOD */
+defcode UMULDIVMOD,"U*/MOD"
+   pop %ecx
+   pop %ebx
+   pop %eax
+   mull %ebx
+   divl %ecx
+   push %edx
+   push %eax
+   NEXT
+
+/* ( x1 -- x2 ) Shift left by one bit */
+defcode TWOMUL,"2*"
+   shll $1,(%esp)
+   NEXT
+
+/* ( n1 -- n2 ) Arithmetic (signed) shift right by one bit */
+defcode TWODIV,"2/"
+   sarl $1,(%esp)
+   NEXT
+
+/* ( u1 -- u2 ) Logical (unsigned) shift right by one bit */
+defcode UTWODIV,"U2/"
+   shrl $1,(%esp)
+   NEXT
+
+/* ( x1 u -- x2 ) Shift left by u bits */
+defcode LSHIFT
+   pop %ecx
+   shll %cl,(%esp)
+   NEXT
+
+/* ( u1 u -- u2 ) Logical (unsigned) shift right by u bits */
+defcode RSHIFT
+   pop %ecx
+   shll %cl,(%esp)
+   NEXT
+
 .macro defzcmp label,opcode,name="\label",flags=0
 defcode \label,"\name",0,\flags
    pop %eax
@@ -895,18 +996,6 @@ defcode INVERT
    notl (%esp)
    NEXT
 
-defcode STORE,"!"
-   pop %ebx
-   pop %eax
-   mov %eax,(%ebx)
-   NEXT
-
-defcode FETCH,"@"
-   pop %ebx
-   mov (%ebx),%eax
-   push %eax
-   NEXT
-
 defcode STOREBYTE,"C!"
    pop %ebx
    pop %eax
@@ -920,6 +1009,48 @@ defcode FETCHBYTE,"C@"
    push %eax
    NEXT
 
+defcode STORE,"!"
+   pop %ebx
+   popl (%ebx)
+   NEXT
+
+defcode FETCH,"@"
+   pop %ebx
+   pushl (%ebx)
+   NEXT
+
+defcode INCREMENT,"+!"
+   pop %ebx
+   pop %eax
+   addl %eax,(%ebx)
+   NEXT
+
+defcode DECREMENT,"-!"
+   pop %ebx
+   pop %eax
+   subl %eax,(%ebx)
+   NEXT
+
+defcode TWOSTORE,"2!"
+   pop %ebx
+   popl (%ebx)
+   popl 4(%ebx)
+   NEXT
+
+defcode TWOFETCH,"2@"
+   pop %ebx
+   pushl 4(%ebx)
+   pushl (%ebx)
+   NEXT
+
+/* ( c-addr u char -- ) Fill u characters starting at c-addr with char */
+defcode FILL
+   pop %eax
+   pop %ecx
+   pop %edi
+   rep stosb
+   NEXT
+
 /* ( src dst n -- ) ( block copy n bytes from src to dst ) */
 defcode CMOVE
    mov %esi,%edx

startup.4th

@@ -37,8 +37,18 @@
 : ] ( -- ) IMMEDIATE TRUE STATE ! ;
 
 \ Separate the division and modulus operators
-: / ( n1 n2 -- n1/n2 ) /MOD NIP ;
+: /MOD  ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> SM/REM ;
-: MOD ( n1 n2 -- n1%n2 ) /MOD DROP ;
+: /     ( n1 n2 --       n1/n2 ) >R S>D R> SM/REM NIP ;
+: MOD   ( n1 n2 -- n1%n2       ) >R S>D R> SM/REM DROP ;
+
+\ Single-cell unsigned division and modulus
+: U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD ;
+: U/    ( u1 u2 --       u1/u2 ) 0 SWAP UM/MOD NIP ;
+: UMOD  ( u1 u2 -- u1%u2       ) 0 SWAP UM/MOD DROP ;
+
+\ Flooring division and modulus (n1%n2 >= 0)
+: FM/MOD ( d1 n1 -- d1%n1 d1/n1 )
+   DUP >R SM/REM OVER 0< IF 1- SWAP R> + SWAP ELSE RDROP THEN ;
 
 \ Names for the standard file descriptor numbers
 0 CONSTANT STDIN
@@ -412,7 +422,7 @@
    CHAR POSTPONE LITERAL ;
 
 \ Return -1, 0, or 1 if n is respectively negative, zero, or positive
-: SIGN ( n -- -1 | 0 | 1 ) DUP IF 0< 2 * 1+ THEN ;
+: SIGNUM ( n -- -1 | 0 | 1 ) DUP IF 0< 2 * 1+ THEN ;
 
 \ Return -1, 0, or 1 if the left string is respectively
 \ less than, equal to, or greater than the right string
@@ -423,7 +433,7 @@
          SWAP ?DUP IF
             ( S: a1 a2 u1 u2 )
             2SWAP 2DUP C@ SWAP C@ - DUP IF
-               >R 4 NDROP R> SIGN EXIT
+               >R 4 NDROP R> SIGNUM EXIT
             ELSE
                DROP
                ( S: u1 u2 a1 a2 )
@@ -442,29 +452,22 @@
       THEN
    AGAIN ;
 
+\ Display the unsigned number at the top of the stack
+: U. ( u -- "<digits>" )
+   \ Start with the highest place-value on the left
+   1000000000
+   \ Skip place-values that would be larger than the input
+   BEGIN 2DUP U< OVER 1 U> AND WHILE 10 U/ REPEAT
+   \ Emit the remaining digits down to the units' place
+   BEGIN
+      TUCK U/MOD [CHAR] 0 + EMIT SWAP
+      DUP 1 U<= IF 2DROP EXIT THEN
+      10 U/
+   AGAIN ;
+
 \ Display the signed number at the top of the stack
-: . ( n -- "<minussign?><digits>" )
+: . ( n -- "<minus?><digits>" )
-   DUP -2147483648 = IF
+   DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ;
-      \ Special case, can't negate due to overflow
-      DROP "-2147483648" TYPE
-   ELSE
-      \ Emit the - sign and use absolute value if input is negative
-      DUP 0< IF
-         [CHAR] - EMIT
-         NEGATE
-      THEN
-      \ Start with the highest place-value on the left
-      1000000000
-      \ Skip place-values that would be larger than the input
-      BEGIN 2DUP < OVER 1 > AND WHILE 10 / REPEAT
-      \ Emit the remaining digits down to the units' place
-      BEGIN
-         TUCK /MOD [CHAR] 0 + EMIT SWAP
-         DUP 1 <= IF 2DROP EXIT THEN
-         10 /
-      AGAIN
-   THEN
-;
 
 \ Field accessors for the search order linked list
 : ORDER>LINK ( a-addr1 -- a-addr2 ) ;
@@ -708,7 +711,7 @@ HIDE ORDER>LINK
          READSTRING
       THEN
    ELSE
-      PUTBACK WORD
+      PUTBACK 64 ALLOT WORD -64 ALLOT
       PARSENUMBER IF
          STATE @ IF
             POSTPONE LITERAL