add more primitives from the ANS FORTH standard
This commit is contained in:
parent
4528e9c5d8
commit
3ae2ff353b
177
jumpforth.S
177
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 */
|
||||
defparam S0 /* initial (empty) data stack pointer */
|
||||
defvalue C0 /* first byte of the heap */
|
||||
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 ) */
|
||||
defcode DIVMOD,"/MOD"
|
||||
pop %ebx
|
||||
/* ( u1 u2 -- ud ) Multiply unsigned, producting a double-cell result */
|
||||
defcode UMMUL,"UM*"
|
||||
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 ) */
|
||||
defcode UDIVMOD,"U/MOD"
|
||||
xor %edx,%edx
|
||||
/* ( ud1 u1 -- ud1%u1 ud1/u1 ) Unsigned division */
|
||||
defcode UMDIVMOD,"UM/MOD"
|
||||
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
|
||||
|
|
|
|||
49
startup.4th
49
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 ) /MOD DROP ;
|
||||
: /MOD ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> SM/REM ;
|
||||
: / ( 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 signed number at the top of the stack
|
||||
: . ( n -- "<minussign?><digits>" )
|
||||
DUP -2147483648 = IF
|
||||
\ 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
|
||||
\ 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 < OVER 1 > AND WHILE 10 / REPEAT
|
||||
BEGIN 2DUP U< OVER 1 U> AND WHILE 10 U/ 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
|
||||
;
|
||||
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 -- "<minus?><digits>" )
|
||||
DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ;
|
||||
|
||||
\ 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue