From 77607934cdf0bf43b3d93ba4cf259ce6b5467a45 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Wed, 21 Oct 2020 20:11:40 -0500 Subject: [PATCH] add a full complement of double-cell primitives --- jumpforth.S | 247 ++++++++++++++++++++++++++++++++++++++++------------ startup.4th | 32 ++++--- 2 files changed, 211 insertions(+), 68 deletions(-) diff --git a/jumpforth.S b/jumpforth.S index e6a073f..4752cec 100644 --- a/jumpforth.S +++ b/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 - NEXT - -/* ( 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) + pop %ebx + pop %eax 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 -.ifdef .Lsetzflag - jmp .Lsetzflag -.else -.Lsetzflag: - movzbl %al,%eax - neg %eax - push %eax + j\ncc 0f + dec %edi +0: push %edi NEXT -.endif .endm -defzcmp ZEQU,sete,"0=" -defzcmp ZNEQU,setne,"0<>" -defzcmp ZLT,setl,"0<" -defzcmp ZGT,setg,"0>" -defzcmp ZLE,setle,"0<=" -defzcmp ZGE,setge,"0>=" +/* ( n|u -- flag ) Equality operators with implicit zero, e.g. flag=d==0 */ +defzcmp ZEQU,ne,"0=" +defzcmp ZNEQU,e,"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 -.ifdef .Lsetflag - jmp .Lsetflag -.else -.Lsetflag: - movzbl %al,%eax - neg %eax - push %eax + j\ncc 0f + dec %edi +0: push %edi NEXT -.endif .endm -/* ( a b -- flag ) ( various comparison operators, e.g. flag=a" -defcmp LT,setl,"<" -defcmp GT,setg,">" -defcmp LE,setle,"<=" -defcmp GE,setge,">=" +/* ( n1|u1 n2|u2 -- flag ) Equality operators */ +defcmp EQU,ne,"=" +defcmp NEQU,e,"<>" -/* unsigned variants */ -defcmp ULT,setb,"U<" -defcmp UGT,seta,"U>" -defcmp ULE,setbe,"U<=" -defcmp UGE,setae,"U>=" +/* ( n1 n2 -- flag ) Signed relational operators */ +defcmp LT,nl,"<" +defcmp GT,ng,">" +defcmp LE,nle,"<=" +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 diff --git a/startup.4th b/startup.4th index 3d1b7e8..1d65b45 100644 --- a/startup.4th +++ b/startup.4th @@ -149,9 +149,25 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) : 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 ) : BYE ( -- ) 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: "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