nybble
/
jumpforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

add a full complement of double-cell primitives

This commit is contained in:
Jesse D. McDonald 2020-10-21 20:11:40 -05:00
parent bcf5d80be0
commit 77607934cd
2 changed files with 211 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

247
jumpforth.S
View File

@ -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<b ) */
defcmp EQU,sete,"="
defcmp NEQU,setne,"<>"
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

32
startup.4th
View File

@ -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