add a full complement of double-cell primitives

jumpforth.S

@@ -657,7 +657,7 @@ defvar CURRENT_ORDER,initial_order,"CURRENT-ORDER"
 
 /* ( a -- ) */
 defcode DROP
-   addl $4,%esp
+   pop %eax
    NEXT
 
 /* ( a b -- b a ) */
@@ -670,7 +670,9 @@ defcode SWAP
 
 /* ( a -- a a ) */
 defcode DUP
-   pushl (%esp)
+   pop %eax
+   push %eax
+   push %eax
    NEXT
 
 /* ( a b -- a b a ) */
@@ -681,7 +683,8 @@ defcode OVER
 /* ( a b -- b ) */
 defcode NIP
    pop %ebx
-   movl %ebx,(%esp)
+   pop %eax
+   push %ebx
    NEXT
 
 /* ( a b -- b a b ) */
@@ -715,19 +718,8 @@ defcode NROT,"-ROT"
 
 /* ( a b -- ) */
 defcode TWODROP,"2DROP"
-   addl $8,%esp
+   pop %ebx
-   NEXT
+   pop %eax
-
-/* ( a b -- a b a b ) */
-defcode TWODUP,"2DUP"
-   pushl 4(%esp)
-   pushl 4(%esp)
-   NEXT
-
-/* ( a b c d -- a b c d a b ) */
-defcode TWOOVER,"2OVER"
-   pushl 12(%esp)
-   pushl 12(%esp)
    NEXT
 
 /* ( a b c d -- c d a b ) */
@@ -742,6 +734,74 @@ defcode TWOSWAP,"2SWAP"
    push %ebx
    NEXT
 
+/* ( a b -- a b a b ) */
+defcode TWODUP,"2DUP"
+   pop %ebx
+   pop %eax
+   push %eax
+   push %ebx
+   push %eax
+   push %ebx
+   NEXT
+
+/* ( a b c d -- a b c d a b ) */
+defcode TWOOVER,"2OVER"
+   pushl 12(%esp)
+   pushl 12(%esp)
+   NEXT
+
+/* ( a b c d -- c d ) */
+defcode TWONIP,"2NIP"
+   pop %edx
+   pop %ecx
+   pop %ebx
+   pop %eax
+   push %ecx
+   push %edx
+   NEXT
+
+/* ( a b c d -- c d a b c d ) */
+defcode TWOTUCK,"2TUCK"
+   pop %edx
+   pop %ecx
+   pop %ebx
+   pop %eax
+   push %ecx
+   push %edx
+   push %eax
+   push %ebx
+   push %ecx
+   push %edx
+   NEXT
+
+/* ( a b c d e f -- c d e f a b ) */
+defcode TWOROT,"2ROT"
+   pop %edx
+   pop %ecx
+   pop %ebx
+   pop %eax
+   xchg %eax,4(%esp)
+   xchg %ebx,(%esp)
+   push %ecx
+   push %edx
+   push %eax
+   push %ebx
+   NEXT
+
+/* ( a b c d e f -- e f a b c d ) */
+defcode NTWOROT,"-2ROT"
+   pop %edx
+   pop %ecx
+   pop %ebx
+   pop %eax
+   xchg %ecx,4(%esp)
+   xchg %edx,(%esp)
+   push %ecx
+   push %edx
+   push %eax
+   push %ebx
+   NEXT
+
 /* ( xn ... x1 n -- ) */
 defcode NDROP
    pop %eax
@@ -777,6 +837,15 @@ defcode QDUP,"?DUP"
    push %eax
 1: NEXT
 
+/* ( 0 -- 0 0 ) */
+/* ( a -- a ) */
+defcode QZDUP,"?0DUP"
+   movl (%esp),%eax
+   test %eax,%eax
+   jnz 1f
+   push %eax
+1: NEXT
+
 /* ( a b -- a+b ) */
 defcode ADD,"+"
    pop %eax
@@ -967,6 +1036,11 @@ defcode DTWODIV,"D2/"
    rcrl $1,4(%esp)
    NEXT
 
+defcode DUTWODIV,"DU2/"
+   shrl $1,(%esp)
+   rcrl $1,4(%esp)
+   NEXT
+
 /* ( x1 u -- x2 ) Shift left by u bits */
 defcode LSHIFT
    pop %ecx
@@ -979,59 +1053,124 @@ defcode RSHIFT
    shrl %cl,(%esp)
    NEXT
 
-.macro defzcmp label,opcode,name="\label",flags=0
+/* ( xd1 u -- xd2 ) Shift left by u bits */
+defcode DLSHIFT
+   pop %ecx
+   movl 4(%esp),%eax
+   shldl %cl,%eax,(%esp)
+   shll %cl,4(%esp)
+   NEXT
+
+/* ( ud1 u -- ud2 ) Logical (unsigned) shift right by u bits */
+defcode DRSHIFT
+   pop %ecx
+   movl (%esp),%eax
+   shrdl %cl,%eax,4(%esp)
+   shrl %cl,(%esp)
+   NEXT
+
+.macro defzcmp label,ncc,name="\label",flags=0
 defcode \label,"\name",0,\flags
    pop %eax
+   xor %edi,%edi
    test %eax,%eax
-   \opcode %al
+   j\ncc 0f
-.ifdef .Lsetzflag
+   dec %edi
-   jmp .Lsetzflag
+0: push %edi
-.else
-.Lsetzflag:
-   movzbl %al,%eax
-   neg %eax
-   push %eax
    NEXT
-.endif
 .endm
 
-defzcmp ZEQU,sete,"0="
+/* ( n|u -- flag ) Equality operators with implicit zero, e.g. flag=d==0 */
-defzcmp ZNEQU,setne,"0<>"
+defzcmp ZEQU,ne,"0="
-defzcmp ZLT,setl,"0<"
+defzcmp ZNEQU,e,"0<>"
-defzcmp ZGT,setg,"0>"
-defzcmp ZLE,setle,"0<="
-defzcmp ZGE,setge,"0>="
 
-.macro defcmp label,opcode,name="\label",flags=0
+/* ( n -- flag ) Signed relational operators with implicit zero, e.g. flag=d<0 */
+defzcmp ZLT,nl,"0<"
+defzcmp ZGT,ng,"0>"
+defzcmp ZLE,nle,"0<="
+defzcmp ZGE,nge,"0>="
+
+.macro defdzcmp label,ncc,name="\label",flags=0
+defcode \label,"\name",0,\flags
+   pop %ebx
+   pop %eax
+   xor %edi,%edi
+   sub $0,%ebx
+   sbb $0,%eax
+   j\ncc 0f
+   dec %edi
+0: push %edi
+   NEXT
+.endm
+
+/* ( d|ud -- flag ) Double-cell equality operators with implicit zero */
+defdzcmp DZEQU,ne,"D0="
+defdzcmp DZNEQU,e,"D0<>"
+
+/* ( d -- flag ) Double-cell signed relational operators with implicit zero */
+defdzcmp DZLT,nl,"D0<"
+defdzcmp DZGT,ng,"D0>"
+defdzcmp DZLE,nle,"D0<="
+defdzcmp DZGE,nge,"D0>="
+
+.macro defcmp label,ncc,name="\label",flags=0
 defcode \label,"\name",0,\flags
    pop %eax
    pop %ebx
+   xor %edi,%edi
    cmp %eax,%ebx
-   \opcode %al
+   j\ncc 0f
-.ifdef .Lsetflag
+   dec %edi
-   jmp .Lsetflag
+0: push %edi
-.else
-.Lsetflag:
-   movzbl %al,%eax
-   neg %eax
-   push %eax
    NEXT
-.endif
 .endm
 
-/* ( a b -- flag ) ( various comparison operators, e.g. flag=a<b ) */
+/* ( n1|u1 n2|u2 -- flag ) Equality operators */
-defcmp EQU,sete,"="
+defcmp EQU,ne,"="
-defcmp NEQU,setne,"<>"
+defcmp NEQU,e,"<>"
-defcmp LT,setl,"<"
-defcmp GT,setg,">"
-defcmp LE,setle,"<="
-defcmp GE,setge,">="
 
-/* unsigned variants */
+/* ( n1 n2 -- flag ) Signed relational operators */
-defcmp ULT,setb,"U<"
+defcmp LT,nl,"<"
-defcmp UGT,seta,"U>"
+defcmp GT,ng,">"
-defcmp ULE,setbe,"U<="
+defcmp LE,nle,"<="
-defcmp UGE,setae,"U>="
+defcmp GE,nge,">="
+
+/* ( u1 u2 -- flag ) Unsigned relational operators */
+defcmp ULT,nb,"U<"
+defcmp UGT,na,"U>"
+defcmp ULE,nbe,"U<="
+defcmp UGE,nae,"U>="
+
+.macro defdcmp label,ncc,name="\label",flags=0
+defcode \label,"\name",0,\flags
+   pop %edx
+   pop %ecx
+   pop %ebx
+   pop %eax
+   xor %edi,%edi
+   sub %edx,%ebx
+   sbb %ecx,%eax
+   j\ncc 0f
+   dec %edi
+0: push %edi
+   NEXT
+.endm
+
+/* ( d1|ud1 d2|ud2 -- flag ) Double-cell equality operators */
+defdcmp DEQU,ne,"D="
+defdcmp DNEQU,e,"D<>"
+
+/* ( d1 d2 -- flag ) Double-cell signed relational operators */
+defdcmp DLT,nl,"D<"
+defdcmp DGT,ng,"D>"
+defdcmp DLE,nle,"D<="
+defdcmp DGE,nge,"D>="
+
+/* ( ud1 ud2 -- flag ) Double-cell unsigned relational operators */
+defdcmp DULT,nb,"DU<"
+defdcmp DUGT,na,"DU>"
+defdcmp DULE,nbe,"DU<="
+defdcmp DUGE,nae,"DU>="
 
 defcode AND
    pop %eax

startup.4th

@@ -149,9 +149,25 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
 : SM/REM ( d1 n1 -- d1%n1 d1/n1 )
    DUP >R FM/MOD DUP IF OVER 0< IF 1+ SWAP R> - SWAP ELSE RDROP THEN THEN ;
 
+\ Signed minimum and maximum
 : MIN 2DUP > IF NIP ELSE DROP THEN ;
 : MAX 2DUP < IF NIP ELSE DROP THEN ;
 
+\ Unsigned minimum and maximum
+: UMIN 2DUP U> IF NIP ELSE DROP THEN ;
+: UMAX 2DUP U< IF NIP ELSE DROP THEN ;
+
+\ Return -1, 0, or 1 if n is respectively negative, zero, or positive
+: SIGNUM ( n -- -1 | 0 | 1 ) DUP IF 0< 2 * 1+ THEN ;
+
+\ Double-cell versions of standard numeric words
+: DABS ( d -- +d ) 2DUP D0< IF DNEGATE THEN ;
+: DMIN ( d1 d2 -- d1|d2 ) 2OVER 2OVER D> IF 2SWAP THEN 2DROP ;
+: DMAX ( d1 d2 -- d1|d2 ) 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
+: DUMIN ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU> IF 2SWAP THEN 2DROP ;
+: DUMAX ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU< IF 2SWAP THEN 2DROP ;
+: DSIGNUM ( d -- -1 | 0 | 1 ) 2DUP D0= IF DROP ELSE D0< 2 * 1+ THEN ;
+
 \ Define names for the whitespace characters
  8 CONSTANT HT  \ Horizontal Tab
 10 CONSTANT LF  \ Line Feed (newline)
@@ -181,15 +197,6 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
 : 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 ;
-
 80 CONSTANT PNO-BUFFER-BYTES
 CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT
 PNO-BUFFER PNO-BUFFER-BYTES + CONSTANT PNO-BUFFER-END
@@ -746,9 +753,6 @@ MARK B
 : [CHAR] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- c ) IMMEDIATE
    CHAR POSTPONE LITERAL ;
 
-\ Return -1, 0, or 1 if n is respectively negative, zero, or positive
-: 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
 : COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 )
@@ -1311,13 +1315,13 @@ DEFINITIONS
             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
+            DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >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
-               OVER CELL- + R> MAX >R
+               OVER CELL- + R> UMAX >R
             ELSE
                DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF
                   "POSTPONE " TYPE