diff --git a/jumpforth.S b/jumpforth.S index de2513b..9ad7a2a 100644 --- a/jumpforth.S +++ b/jumpforth.S @@ -777,13 +777,6 @@ 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 @@ -854,28 +847,78 @@ defcode UMMUL,"UM*" 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 - idivl %ebx +/* ( n -- d ) Convert a single-cell signed integer to a double-cell integer */ +defcode STOD,"S>D" + movl (%esp),%eax + cltd push %edx - push %eax NEXT -/* ( ud1 u1 -- ud1%u1 ud1/u1 ) Unsigned division */ +/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell addition */ +defcode DADD,"D+" + pop %ebx + pop %eax + addl %eax,4(%esp) + adcl %ebx,(%esp) + NEXT + +/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell subtraction */ +defcode DSUB,"D-" + pop %ebx + pop %eax + subl %eax,4(%esp) + sbbl %ebx,(%esp) + NEXT + +defcode DNEGATE + notl 4(%esp) + notl (%esp) + addl $1,4(%esp) + adcl $0,(%esp) + NEXT + +/* ( d1 +n1 -- n-remainder d-quotient ) Flooring division with remainder */ +/* NOTE: ANS FORTH has the quotient as a single-cell value (with potential overflow) */ +/* WARNING: This implementation does not handle negative divisors (just dividends) */ +defcode FMDIVMOD,"FM/MOD" + pop %ebx /* divisor */ + pop %eax /* upper 32 bits of dividend */ + cdq + idivl %ebx + test %edx,%edx + jns 0f + dec %eax + add %ebx,%edx +0: mov %eax,%ecx + pop %eax /* lower 32 bits of dividend */ + div %ebx + push %edx /* modulus */ + push %eax /* lower 32 bits of quotient */ + push %ecx /* upper 32 bits of quotient */ + NEXT + +/* ( ud1 u1 -- u-modulus ud-quotient ) Unsigned division with remainder */ +/* NOTE: ANS FORTH has the quotient as a single-cell value (with potential overflow) */ defcode UMDIVMOD,"UM/MOD" pop %ebx pop %edx - pop %eax + cmp %ebx,%edx + jae 1f + xor %ecx,%ecx +0: pop %eax divl %ebx push %edx push %eax + push %ecx NEXT +1: mov %edx,%eax + xor %edx,%edx + divl %ebx + mov %eax,%ecx + jmp 0b /* ( n1 n2 n3 -- (n1*n2)%n3 (n1*n2)/n3 ) */ -/* Equivalent to >R M* R> SM/MOD */ +/* Equivalent to >R M* R> SM/MOD S>D */ /* Note: The intermediate value between multiplication and division is 64 bits */ defcode MULDIVMOD,"*/MOD" pop %ecx @@ -888,7 +931,7 @@ defcode MULDIVMOD,"*/MOD" NEXT /* Same as MULDIVMOD but for unsigned inputs */ -/* Equivalent to >R UM* R> UM/MOD */ +/* Equivalent to >R UM* R> UM/MOD DROP */ defcode UMULDIVMOD,"U*/MOD" pop %ecx pop %ebx @@ -914,6 +957,16 @@ defcode UTWODIV,"U2/" shrl $1,(%esp) NEXT +defcode DTWOMUL,"D2*" + shll $1,4(%esp) + rcll $1,(%esp) + NEXT + +defcode DTWODIV,"D2/" + sarl $1,(%esp) + rcrl $1,4(%esp) + NEXT + /* ( x1 u -- x2 ) Shift left by u bits */ defcode LSHIFT pop %ecx @@ -1205,6 +1258,14 @@ defcode LIT push %eax NEXT +defcode TWOLIT,"2LIT" + lodsl + mov %eax,%ebx + lodsl + push %eax + push %ebx + NEXT + defcode LITSTRING xor %eax,%eax lodsb diff --git a/startup.4th b/startup.4th index 665f801..e1a779a 100644 --- a/startup.4th +++ b/startup.4th @@ -127,19 +127,22 @@ CREATE THROWN-STRING 0 , 0 , : [ ( -- ) IMMEDIATE FALSE STATE ! ; : ] ( -- ) IMMEDIATE TRUE STATE ! ; +\ Convert from a double-cell signed number to a single-cell signed number +: D>S ( d -- n ) DROP ; + \ Separate the division and modulus operators -: /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 ; +: /MOD ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> FM/MOD D>S ; +: / ( n1 n2 -- n1/n2 ) >R S>D R> FM/MOD D>S NIP ; +: MOD ( n1 n2 -- n1%n2 ) >R S>D R> FM/MOD 2DROP ; \ 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 ; +: U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD DROP ; +: U/ ( u1 u2 -- u1/u2 ) 0 SWAP UM/MOD DROP NIP ; +: UMOD ( u1 u2 -- u1%u2 ) 0 SWAP UM/MOD 2DROP ; -\ 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 ; +\ Symmetric division and remainder +: 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 ; : MIN 2DUP > IF NIP ELSE DROP THEN ; : MAX 2DUP < IF NIP ELSE DROP THEN ; @@ -173,6 +176,15 @@ CREATE THROWN-STRING 0 , 0 , : 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 ; + \ Display the unsigned number at the top of the stack : U. ( u -- "" ) \ Start with the highest place-value on the left @@ -232,11 +244,14 @@ CREATE THROWN-STRING 0 , 0 , CP ! ; +\ Allocate one character from the data area and fill it with the value on the stack +: C, HERE 1 ALLOT C! ; + \ Allocate one cell from the data area and fill it with the value on the stack : , HERE CELL ALLOT ! ; -\ Allocate one character from the data area and fill it with the value on the stack -: C, HERE 1 ALLOT C! ; +\ Allocate two cells from the data area and fill them with the values on the stack +: 2, HERE [ 2 CELLS ] LITERAL ALLOT 2! ; \ Allocate bytes from the data area (less than one cell) to cell-align the address : ALIGN HERE ALIGNED HERE - BEGIN ?DUP WHILE 0 C, 1- REPEAT ; @@ -254,6 +269,9 @@ CREATE THROWN-STRING 0 , 0 , : SLITERAL ( Compilation: c-addr1 u -- ) ( Runtime: -- c-addr2 u ) IMMEDIATE POSTPONE LITSTRING DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN ; +: 2LITERAL ( Compilation: x1 x2 -- ) ( Runtime: -- x1 x2 ) IMMEDIATE + POSTPONE 2LIT 2, ; + \ Append the execution semantics of the current definition to the current definition : RECURSE ( -- ) IMMEDIATE LATEST COMPILE, ; @@ -453,6 +471,17 @@ CREATE CURRENT-SOURCE-ID -1 , : MARK IMMEDIATE WORD POSTPONE SLITERAL POSTPONE (MARK) ; ' (MARK) (HIDE) +\ Define a threaded FORTH word +\ The word is initially hidden so it can refer to a prior word with the same name +\ The definition is terminated with the ; immediate word, which unhides the name +: : ( "ccc" -- ) + CREATE LATEST DUP (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ; + +\ End a definition by appending EXIT and leaving compilation mode +\ Unhide the name if it isn't empty (e.g. from :NONAME) +: ; ( -- ) IMMEDIATE + POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ; + \ Define a named constant \ Execution: ( value "name" -- ) \ name Execution: ( -- value ) @@ -464,12 +493,18 @@ CREATE CURRENT-SOURCE-ID -1 , \ : CONSTANT : POSTPONE LITERAL POSTPONE ; ; : CONSTANT CREATE LATEST >DFA ! ; +\ Same for double-cell constants; no DFA trick this time +: 2CONSTANT : POSTPONE 2LITERAL POSTPONE ; ; + \ Define a single-cell named variable which returns its data address when executed. \ The initial value is formally undefined. This implementation sets it to zero. \ Execution: ( "name" -- ) \ name Execution: ( -- a-addr ) : VARIABLE CREATE 0 , ; +\ Same for double-cell variables (two-variables) +: 2VARIABLE CREATE [ 0 0 ] 2LITERAL 2, ; + \ Define a single-cell named value which returns its data (not address) when executed. \ Named values defined with VALUE can be modified with TO. \ Execution: ( x "name" -- ) @@ -486,12 +521,6 @@ CREATE CURRENT-SOURCE-ID -1 , : 2ARRAY ( n "name" -- ) CREATE CELLS 2* ALLOT DOES> SWAP [ 2 CELLS ] LITERAL * + ; -\ Define a threaded FORTH word -\ The word is initially hidden so it can refer to a prior word with the same name -\ The definition is terminated with the ; immediate word, which unhides the name -: : ( "ccc" -- ) - CREATE LATEST DUP (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ; - \ Define a threaded word which also displays its name and the data stack when called : (TRACE) >NAME TYPE SPACE .DS EOL ; : :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; @@ -504,11 +533,6 @@ CREATE CURRENT-SOURCE-ID -1 , ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C, DUP GET-CURRENT ! ALIGN POSTPONE ] ; -\ End a definition by appending EXIT and leaving compilation mode -\ Unhide the name if it isn't empty (e.g. from :NONAME) -: ; ( -- ) IMMEDIATE - POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ; - \ Fetch and store the target of the deferred word denoted by deferred-xt \ Note that this DEFER! can turn any word into a deferred word : DEFER@ ( deferred-xt -- xt ) >DFA @ ; @@ -1229,31 +1253,33 @@ DEFINITIONS DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF 2DROP RDROP EXIT THEN - DUP ['] LIT = IF - DROP @(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE - ELSE - DUP ['] LITSTRING = IF - DROP DUP C@ OVER 1+ OVER - "\"" TYPE TYPE-ESCAPED "\"" TYPE SPACE - + ALIGNED + CASE + ['] LIT OF + @(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE + ENDOF + ['] 2LIT OF + "[ " TYPE @(+) U. SPACE @(+) . " ] 2LITERAL " TYPE + ENDOF + ['] LITSTRING OF + 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 + "{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE ELSE - OVER CELL- NONAME-LITERAL? IF - DROP DUP @ OVER + 2 CELLS+ DUP R> MAX >R SWAP - "{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE + DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF + >NAME TYPE SPACE + @(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "} " TYPE + OVER CELL- + R> MAX >R ELSE - DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF - >NAME TYPE SPACE - @(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "}" TYPE SPACE - OVER CELL- + R> MAX >R - ELSE - DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF - "POSTPONE " TYPE - THEN - .W SPACE + DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF + "POSTPONE " TYPE THEN + .W SPACE THEN THEN - THEN + DUP \ placeholder to be dropped by ENDCASE since we consumed the xt + ENDCASE AGAIN ; HIDE NONAME-LITERAL? @@ -1261,13 +1287,13 @@ HIDE NONAME-LITERAL? : SEE ( "name" -- ) ' DUP >CFA @ CASE DOCOL OF - ": " TYPE DUP >NAME TYPE - DUP IMMEDIATE? IF " IMMEDIATE" TYPE THEN - " " TYPE >DFA @ UNTHREAD ";\n" TYPE + ": " TYPE DUP >NAME TYPE " " TYPE + DUP IMMEDIATE? IF "IMMEDIATE " TYPE THEN + >DFA @ UNTHREAD ";\n" TYPE ENDOF DODEFER OF - "DEFER " TYPE DUP >NAME TYPE " ' " TYPE DUP >DFA @ .W - " IS " TYPE >NAME TYPE EOL + "DEFER " TYPE DUP >NAME TYPE EOL + DUP >DFA @ DUP WORD? IF "' " TYPE .W ELSE U. THEN " IS " TYPE >NAME TYPE EOL ENDOF DODATA OF DUP EXECUTE . " CONSTANT " TYPE >NAME TYPE EOL @@ -1277,7 +1303,7 @@ HIDE NONAME-LITERAL? ENDOF DODOES OF "CREATE " TYPE DUP >NAME TYPE " … DOES> " TYPE - " " TYPE >DFA @ UNTHREAD ";\n" TYPE + >DFA @ UNTHREAD ";\n" TYPE ENDOF \ Anything else can be assumed to be implemented in assembly SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE