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

reset RSP to saved frame pointer on exit; eliminates UNLOOP, UNLOCALS, UNALLOCA

This commit is contained in:
Jesse D. McDonald 2020-11-15 03:54:26 -06:00
parent c9be49b8a9
commit 35c6641a21
3 changed files with 236 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
jumpforth.S
View File

@ -72,6 +72,8 @@ _start:
.globl DOCOL .globl DOCOL
DOCOL: DOCOL:
PUSHRSP %esi PUSHRSP %esi
PUSHRSP %edi
mov %ebp,%edi
movl 4(%eax),%esi movl 4(%eax),%esi
NEXT NEXT
@ -112,8 +114,11 @@ DOLOAD:
.balign 4 .balign 4
.globl DODOES .globl DODOES
DODOES: DODOES:
/* Save threaded return address */ /* Save threaded return address and frame pointer */
PUSHRSP %esi PUSHRSP %esi
PUSHRSP %edi
/* Save the new frame pointer */
mov %ebp,%edi
/* Load address of DOES> body from DFA into %esi */ /* Load address of DOES> body from DFA into %esi */
movl 4(%eax),%esi movl 4(%eax),%esi
/* Load address of word body (after DFA) onto stack */ /* Load address of word body (after DFA) onto stack */
@ -1078,16 +1083,26 @@ defcode NRFETCH,"NR@"
mov %edx,%edi mov %edx,%edi
NEXT NEXT
/* ( -- a-addr ) */ /* ( -- a-addr ) Fetch the return stack pointer */
defcode RSPFETCH,"RSP@" defcode RSPFETCH,"RSP@"
push %ebp push %ebp
NEXT NEXT
/* ( a-addr -- ) */ /* ( a-addr -- ) Set the return stack pointer */
defcode RSPSTORE,"RSP!" defcode RSPSTORE,"RSP!"
pop %ebp pop %ebp
NEXT NEXT
/* ( -- a-addr ) Fetch the frame pointer */
defcode FPPFETCH,"FP@"
push %edi
NEXT
/* ( a-addr -- ) Set the frame pointer */
defcode FPSTORE,"FP!"
pop %edi
NEXT
/* ( R: x -- ) */ /* ( R: x -- ) */
defcode RDROP defcode RDROP
addl $4,%ebp addl $4,%ebp
@ -1104,6 +1119,14 @@ defcode NRDROP
lea (%ebp,%eax,4),%ebp lea (%ebp,%eax,4),%ebp
NEXT NEXT
/* ( u-bytes -- a-addr R: -- i*x ) Reserve aligned space on the return stack */
defcode ALLOCA
pop %eax
sub %eax,%ebp
and $-8,%ebp
push %ebp
NEXT
/* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */ /* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */
defcode SPFETCH,"SP@" defcode SPFETCH,"SP@"
push %esp push %esp
@ -1149,10 +1172,10 @@ defcode ZBRANCH,"0BRANCH"
.macro deflocals idx:req,fetch_label:req,fetch_name:req,store_label:req,store_name:req .macro deflocals idx:req,fetch_label:req,fetch_name:req,store_label:req,store_name:req
defcode \fetch_label,\fetch_name defcode \fetch_label,\fetch_name
pushl ((\idx + 1) * 4)(%ebp) pushl ((\idx + 1) * -4)(%edi)
NEXT NEXT
defcode \store_label,\store_name defcode \store_label,\store_name
popl ((\idx + 1) * 4)(%ebp) popl ((\idx + 1) * -4)(%edi)
NEXT NEXT
.endm .endm
@ -1166,6 +1189,8 @@ deflocals 6,FETCH_L6,"L6@",STORE_L6,"L6!"
deflocals 7,FETCH_L7,"L7@",STORE_L7,"L7!" deflocals 7,FETCH_L7,"L7@",STORE_L7,"L7!"
defcode EXIT defcode EXIT
mov %edi,%ebp
POPRSP %edi
POPRSP %esi POPRSP %esi
NEXT NEXT
@ -1537,9 +1562,9 @@ defword INTERPRET,,F_HIDDEN
7: .int COMMA,EXIT 7: .int COMMA,EXIT
defword QUIT,,F_HIDDEN defword QUIT,,F_HIDDEN
.int R0,RSPSTORE .int R0,RSPSTORE,LIT,0,FPSTORE
0: .int INTERPRET,BRANCH,(0b - .) 0: .int INTERPRET,BRANCH,(0b - .)
.int EXIT .int EXIT /* marker only - unreachable */
defword LATEST,,F_HIDDEN defword LATEST,,F_HIDDEN
.int CURRENT,FETCH,FETCH,EXIT .int CURRENT,FETCH,FETCH,EXIT
@ -1679,3 +1704,5 @@ startup_defs_end:
return_stack: return_stack:
.space RETURN_STACK_SIZE .space RETURN_STACK_SIZE
return_stack_top: return_stack_top:
/* vim:set syntax=gas: */

346
startup.4th
View File

@ -994,11 +994,9 @@ CREATE LEAVE-ORIG NULL ,
POSTPONE BEGIN ; POSTPONE BEGIN ;
: LEAVE ( C: -- ; -- R: limit index -- ) IMMEDIATE : LEAVE ( C: -- ; -- R: limit index -- ) IMMEDIATE
LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ; LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ;
: UNLOOP ( R: limit index -- ) IMMEDIATE
POSTPONE 2RDROP ;
: +LOOP ( C: outer-stack dest -- ; n -- R: {limit index} -- ) IMMEDIATE : +LOOP ( C: outer-stack dest -- ; n -- R: {limit index} -- ) IMMEDIATE
POSTPONE RSP@ POSTPONE +! POSTPONE 2R@ POSTPONE = POSTPONE UNTIL POSTPONE RSP@ POSTPONE +! POSTPONE 2R@ POSTPONE = POSTPONE UNTIL
LEAVE-ORIG XCHG POSTPONE THEN POSTPONE UNLOOP ; LEAVE-ORIG XCHG POSTPONE THEN POSTPONE 2RDROP ;
: LOOP ( C: outer-stack dest -- ; -- R: {limit index} -- ) IMMEDIATE : LOOP ( C: outer-stack dest -- ; -- R: {limit index} -- ) IMMEDIATE
1 POSTPONE LITERAL POSTPONE +LOOP ; 1 POSTPONE LITERAL POSTPONE +LOOP ;
' LEAVE-ORIG (HIDE) ' LEAVE-ORIG (HIDE)
@ -1073,7 +1071,7 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
\ Return the number of words on the data and return stacks, respectively \ Return the number of words on the data and return stacks, respectively
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ; : DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
: RDEPTH ( -- n ) R0 RSP@ CELL+ - CELL / ; : RDEPTH ( -- n ) R0 FP@ 2 CELLS+ - CELL / ;
' SYSTEM (DEFINITIONS) ' SYSTEM (DEFINITIONS)
@ -1103,9 +1101,9 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
\ Display the content of the return stack \ Display the content of the return stack
: .RS ( -- "<text>" ) : .RS ( -- "<text>" )
\ Skip the topmost cell, which is the return address for the call to .RS \ Skip the topmost two cells, this call's return address and frame pointer
"R(" TYPE RDEPTH 1- . "):" TYPE "R(" TYPE RDEPTH 2 - . "):" TYPE
RSP@ CELL+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN FP@ 2 CELLS+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN
DUP R0 <> IF " …" TYPE THEN DUP R0 <> IF " …" TYPE THEN
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ; BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
@ -1221,7 +1219,7 @@ CREATE EXCEPTION-STACK NULL ,
EXCEPTION-STACK @ RSP! EXCEPTION-STACK @ RSP!
2R> ▪ [[ ' THROW-UNWIND ]] DEFER! ▪ EXCEPTION-STACK ! 2R> ▪ [[ ' THROW-UNWIND ]] DEFER! ▪ EXCEPTION-STACK !
R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP
R> SWAP >R SP! R> ; R> FP! ▪ R> SWAP >R SP! R> ;
' UTILITY (DEFINITIONS) ' UTILITY (DEFINITIONS)
@ -1238,6 +1236,8 @@ CREATE EXCEPTION-STACK NULL ,
RSP@ RSP@
\ Save the stack pointer but don't include the xt and RSP on the top \ Save the stack pointer but don't include the xt and RSP on the top
SP@ 2 CELLS+ >R SP@ 2 CELLS+ >R
\ Save the frame pointer
FP@ >R
\ Save the input source specification \ Save the input source specification
SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R
\ We'll need these to revert the effect of CATCH, with or without THROW \ We'll need these to revert the effect of CATCH, with or without THROW
@ -1317,6 +1317,12 @@ DEFER REFILL
\ The default target for DEFER words until initialized with DEFER! or IS \ The default target for DEFER words until initialized with DEFER! or IS
: (DEFER-UNINITIALIZED) EXCP-DEFER-UNINITIALIZED THROW ; : (DEFER-UNINITIALIZED) EXCP-DEFER-UNINITIALIZED THROW ;
DEFER BEGIN-WORD-HOOK
' NO-OP ' BEGIN-WORD-HOOK DEFER!
DEFER END-WORD-HOOK
' NO-OP ' END-WORD-HOOK DEFER!
' UTILITY (DEFINITIONS) ' UTILITY (DEFINITIONS)
\ Use to create words programmatically without reading the name from the input \ Use to create words programmatically without reading the name from the input
@ -1327,7 +1333,8 @@ DEFER REFILL
\ The word is initially hidden so it can refer to a prior word with the same name \ 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 \ The definition is terminated with the ; immediate word, which unhides the name
: (:) ( c-addr u -- ) : (:) ( c-addr u -- )
(CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ] ; (CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ]
BEGIN-WORD-HOOK ;
' FORTH (DEFINITIONS) ' FORTH (DEFINITIONS)
@ -1335,12 +1342,14 @@ DEFER REFILL
\ where <addr> is the next address after the "EXIT" as a literal number \ where <addr> is the next address after the "EXIT" as a literal number
\ Stay in compilation mode for the body of the DOES> clause \ Stay in compilation mode for the body of the DOES> clause
: DOES> IMMEDIATE : DOES> IMMEDIATE
POSTPONE LIT HERE NULL , ▪ POSTPONE (DOES) POSTPONE EXIT ▪ HERE SWAP ! ; POSTPONE LIT HERE NULL , ▪ POSTPONE (DOES)
END-WORD-HOOK ▪ POSTPONE EXIT ▪ HERE SWAP ! ;
\ End a definition by appending EXIT and leaving compilation mode \ End a definition by appending EXIT and leaving compilation mode
\ Unhide the name if it isn't empty (e.g. from :NONAME) \ Unhide the name if it isn't empty (e.g. from :NONAME)
: ; IMMEDIATE : ; IMMEDIATE
POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ; END-WORD-HOOK ▪ POSTPONE EXIT POSTPONE [
LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ;
' UTILITY (DEFINITIONS) ' UTILITY (DEFINITIONS)
@ -1465,6 +1474,12 @@ DEFER REFILL
: %SIZEOF ( align size -- size ) NIP ; : %SIZEOF ( align size -- size ) NIP ;
: %ALIGNOF ( align size -- align ) DROP ; : %ALIGNOF ( align size -- align ) DROP ;
DEFER SUSPEND-WORD-HOOK
' NO-OP ' SUSPEND-WORD-HOOK DEFER!
DEFER RESUME-WORD-HOOK
' NO-OP ' RESUME-WORD-HOOK DEFER!
\ Inline :NONAME-style function literals. "{ <code> }" has the runtime effect \ Inline :NONAME-style function literals. "{ <code> }" has the runtime effect
\ of placing the execution token for an anonymous function with the runtime \ of placing the execution token for an anonymous function with the runtime
\ effect of <code> on the top of the data stack. A branch is emitted to skip \ effect of <code> on the top of the data stack. A branch is emitted to skip
@ -1484,9 +1499,10 @@ DEFER REFILL
\ Compilation effect: ( C: -- outer-xt orig inner-xt state ) \ Compilation effect: ( C: -- outer-xt orig inner-xt state )
\ Interpreter effect: ( S: -- inner-xt state ) \ Interpreter effect: ( S: -- inner-xt state )
\ Enters compilation mode if not already compiling \ Enters compilation mode if not already compiling
: { ( -- {outer-xt orig} inner-xt state ) IMMEDIATE : { ( -- {i*x outer-xt orig} inner-xt state ) IMMEDIATE
STATE @ STATE @
DUP IF DUP IF
>R SUSPEND-WORD-HOOK R>
LATEST LATEST
NULL OVER >LINK XCHG LATEST! NULL OVER >LINK XCHG LATEST!
POSTPONE AHEAD POSTPONE AHEAD
@ -1501,7 +1517,7 @@ DEFER REFILL
\ Resolve the forward branch over the inner function \ Resolve the forward branch over the inner function
\ Add outer-xt back to the word list after inner-xt \ Add outer-xt back to the word list after inner-xt
\ Generate a literal for inner-xt \ Generate a literal for inner-xt
: } ( {outer-xt orig} inner-xt state -- {inner-xt} ) IMMEDIATE : } ( {i*x outer-xt orig} inner-xt state -- {inner-xt} ) IMMEDIATE
POSTPONE ; POSTPONE ;
IF IF
( S: outer-xt orig inner-xt ) ( S: outer-xt orig inner-xt )
@ -1513,6 +1529,8 @@ DEFER REFILL
POSTPONE ] POSTPONE ]
\ Compile inner-xt as a literal in the outer definition \ Compile inner-xt as a literal in the outer definition
POSTPONE LITERAL POSTPONE LITERAL
\ Perform any necessary bookkeeping to compile code in the outer word again
RESUME-WORD-HOOK
\ ELSE ( nothing to do ) \ ELSE ( nothing to do )
( S: inner-xt ) ( S: inner-xt )
THEN ; THEN ;
@ -1789,32 +1807,17 @@ ENDSTRUCT MEMBLOCK%
\ The xt points to the codeword, which is two cells above the base of the object \ The xt points to the codeword, which is two cells above the base of the object
: FREE-CLOSURE ( closure-xt -- ) 2 CELLS- FREE ; : FREE-CLOSURE ( closure-xt -- ) 2 CELLS- FREE ;
' SYSTEM (DEFINITIONS)
0x33A110CA CONSTANT ALLOCA-MARK
: ?ALLOCA-MARK R> R@ ALLOCA-MARK <> "mismatched UNALLOCA" ?FAIL >R ;
' FORTH (DEFINITIONS) ' FORTH (DEFINITIONS)
\ NOTE: ALLOCA, UNALLOCA, and %ALLOCA all assume that the return address
\ ("nest-sys" in ANS FORTH) is a single cell which may be relocated.
\ Allocate some space from the return stack; must release with UNALLOCA
: ALLOCA ( bytes -- a-addr )
R> RSP@ ROT OVER SWAP - -8 AND DUP RSP! -ROT >R ALLOCA-MARK >R >R ;
\ Release return-stack space reserved with ALLOCA
: UNALLOCA R> ?ALLOCA-MARK RDROP R> RSP! >R ;
\ Reserve data or heap space for a data structure given alignment and size \ Reserve data or heap space for a data structure given alignment and size
\ It is assumed that ALLOCATE and ALLOCA (but not ALLOT) return addresses \ It is assumed that ALLOCATE and ALLOCA (but not ALLOT) return addresses
\ suitably aligned for any primitive data type; %ALLOCATE and %ALLOCA are \ suitably aligned for any primitive data type; %ALLOCATE and %ALLOCA are
\ not suitable for data structures with unusually high alignment requirements \ not suitable for data structures with unusually high alignment requirements
\ %ALLOCATE must be paired with FREE; %ALLOCA must be paired with UNALLOCA
: %ALLOT ( align bytes -- a-addr ) SWAP ALIGN-TO HERE SWAP ALLOT ; : %ALLOT ( align bytes -- a-addr ) SWAP ALIGN-TO HERE SWAP ALLOT ;
: %ALLOCATE ( align bytes -- a-addr ) %SIZEOF ALLOCATE ; : %ALLOCATE ( align bytes -- a-addr ) %SIZEOF ALLOCATE ;
: %ALLOCA ( align bytes -- a-addr ) NIP R> SWAP ALLOCA SWAP >R ;
: %ALLOCA ( Runtime: align bytes -- a-addr ) IMMEDIATE
POSTPONE NIP POSTPONE ALLOCA ;
\ Reserve data space for a data structure and give it a name \ Reserve data space for a data structure and give it a name
\ The content is indeterminate and must be initialized before the first use \ The content is indeterminate and must be initialized before the first use
@ -1977,7 +1980,7 @@ UTILITY DEFINITIONS
\ TRUE if x is equal to one of the u cells starting at a-addr; FALSE otherwise \ TRUE if x is equal to one of the u cells starting at a-addr; FALSE otherwise
: ELEMENT? ( x a-addr u -- flag ) : ELEMENT? ( x a-addr u -- flag )
0 ?DO 2DUP I CELLS+ @ = ?DUP IF 2DROP UNLOOP EXIT THEN LOOP 2DROP FALSE ; 0 ?DO 2DUP I CELLS+ @ = ?DUP IF 2DROP EXIT THEN LOOP 2DROP FALSE ;
: REMOVE-DUPLICATES ( xu ... x1 u -- xu' ... x1' u' ) : REMOVE-DUPLICATES ( xu ... x1 u -- xu' ... x1' u' )
DUP ▪ BEGIN ▪ DUP WHILE DUP ▪ BEGIN ▪ DUP WHILE
@ -2254,14 +2257,14 @@ SYSTEM DEFINITIONS
FORTH DEFINITIONS FORTH DEFINITIONS
: TTY? ( fd -- flag ) : TTY? ( fd -- flag )
IOCTL_TCGETS termios% %ALLOCA SYS_IOCTL SYSCALL3-RETRY UNALLOCA 0= ; IOCTL_TCGETS termios% %ALLOCA SYS_IOCTL SYSCALL3-RETRY 0= ;
STDIN TTY? CONSTANT INTERACTIVE? STDIN TTY? CONSTANT INTERACTIVE?
\ Empty the return stack, make stdin the input source, and enter interpretation state \ Empty the return stack, make stdin the input source, and enter interpretation state
:FINALIZE QUIT ( -- <noreturn> ) :FINALIZE QUIT ( -- <noreturn> )
CATCHING? IF EXCP-QUIT THROW THEN CATCHING? IF EXCP-QUIT THROW THEN
R0 RSP! R0 RSP! ▪ NULL FP!
0 CURRENT-SOURCE-ID ! 0 CURRENT-SOURCE-ID !
FALSE STATE ! FALSE STATE !
BEGIN BEGIN
@ -2287,7 +2290,7 @@ REVERT
DUP HASHCELL ▪ DUP #REPORTERS + SWAP ?DO DUP HASHCELL ▪ DUP #REPORTERS + SWAP ?DO
I #REPORTERS 1- AND ▪ REPORTERS I #REPORTERS 1- AND ▪ REPORTERS
2DUP 2@ SWAP -ROT = TUCK SWAP NULL= OR IF 2DUP 2@ SWAP -ROT = TUCK SWAP NULL= OR IF
ROT DROP UNLOOP EXIT ROT DROP EXIT
THEN ▪ 2DROP THEN ▪ 2DROP
LOOP ▪ DROP NULL FALSE ; LOOP ▪ DROP NULL FALSE ;
@ -2331,7 +2334,7 @@ SYSTEM DEFINITIONS
{ "Uninitialized deferred word\n" TYPE } EXCP-DEFER-UNINITIALIZED REPORTER! { "Uninitialized deferred word\n" TYPE } EXCP-DEFER-UNINITIALIZED REPORTER!
: DEFAULT-UNWIND ( i*x n -- <noreturn> ) : DEFAULT-UNWIND ( i*x n -- <noreturn> )
R0 RSP! >R S0 SP! R> >STDERR REPORT >STDOUT QUIT ; R0 RSP! ▪ >R S0 SP! R> ▪ NULL FP! ▪ >STDERR REPORT >STDOUT ▪ QUIT ;
' DEFAULT-UNWIND IS THROW-UNWIND ' DEFAULT-UNWIND IS THROW-UNWIND
\ Switch to the interpreter defined in this startup file \ Switch to the interpreter defined in this startup file
@ -2351,6 +2354,7 @@ SYSTEM DEFINITIONS
STRUCT STRUCT
CELL% FIELD LOCAL>LINK CELL% FIELD LOCAL>LINK
CELL% FIELD LOCAL>INDEX
CELL% FIELD LOCAL>LENGTH CELL% FIELD LOCAL>LENGTH
CHAR% 0 * FIELD LOCAL>NAME-ADDR CHAR% 0 * FIELD LOCAL>NAME-ADDR
ENDSTRUCT LOCAL% ENDSTRUCT LOCAL%
@ -2361,6 +2365,8 @@ ENDSTRUCT LOCAL%
: LOCAL>NAME ( local -- c-addr u ) DUP LOCAL>NAME-ADDR SWAP LOCAL>LENGTH @ ; : LOCAL>NAME ( local -- c-addr u ) DUP LOCAL>NAME-ADDR SWAP LOCAL>LENGTH @ ;
NULL VALUE LOCAL-NAMES NULL VALUE LOCAL-NAMES
VARIABLE CURRENT-LOCALS
0 CURRENT-LOCALS !
8 CONSTANT #LOCALS 8 CONSTANT #LOCALS
#LOCALS ARRAY LOCAL-FETCHERS #LOCALS ARRAY LOCAL-FETCHERS
@ -2373,27 +2379,46 @@ MARKER REVERT
REVERT REVERT
: LOCAL-INDEX ( c-addr u1 -- u2 TRUE | FALSE ) : LOCAL-INDEX ( c-addr u1 -- u2 TRUE | FALSE )
LOCAL-NAMES #LOCALS 0 ?DO 2>R ▪ LOCAL-NAMES ▪ BEGIN ▪ ?DUP WHILE
DUP NULL= IF LEAVE THEN DUP LOCAL>NAME 2R@ COMPARE 0= IF
>R 2DUP R@ LOCAL>NAME COMPARE R> SWAP 0= IF 2RDROP LOCAL>INDEX @ TRUE EXIT
DROP 2DROP I TRUE UNLOOP EXIT
THEN THEN
LOCAL>LINK @ LOCAL>LINK @
LOOP ▪ DROP ▪ 2DROP ▪ FALSE ; REPEAT ▪ 2RDROP ▪ FALSE ;
: LOCAL-LOOKUP ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) : LOCAL-LOOKUP ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
2DUP FALSE >R 2DUP FALSE >R
DUP 1 > IF ▪ 2DUP + 1- C@ [[ CHAR ! ]] = IF ▪ 1- RDROP TRUE >R ▪ THEN ▪ THEN DUP 1 > IF ▪ 2DUP + 1- C@ [[ CHAR ! ]] = IF ▪ 1- RDROP TRUE >R ▪ THEN ▪ THEN
LOCAL-INDEX 0= IF RDROP 0 EXIT THEN LOCAL-INDEX 0= IF RDROP 0 EXIT THEN
DUP #LOCALS U>= IF DROP RDROP 0 EXIT THEN ( TODO: generate code for more locals )
R> 2NIP IF LOCAL-STORERS ELSE LOCAL-FETCHERS THEN @ 1 ; R> 2NIP IF LOCAL-STORERS ELSE LOCAL-FETCHERS THEN @ 1 ;
{ LOCAL-LOOKUP ?DUP 0= IF DEFERS FIND-HOOK THEN } IS FIND-HOOK { LOCAL-LOOKUP ?DUP 0= IF DEFERS FIND-HOOK THEN } IS FIND-HOOK
: RESET-LOCALS NULL TO LOCAL-NAMES ▪ 0 CURRENT-LOCALS ! ;
: SUSPEND-LOCALS LOCAL-NAMES ▪ CURRENT-LOCALS @ ▪ RESET-LOCALS ;
: RESUME-LOCALS CURRENT-LOCALS ! ▪ TO LOCAL-NAMES ;
: FREE-LOCALS
LOCAL-NAMES ▪ RESET-LOCALS
BEGIN ?DUP WHILE DUP LOCAL>LINK @ SWAP FREE REPEAT ;
{ DEFERS BEGIN-WORD-HOOK ▪ RESET-LOCALS } IS BEGIN-WORD-HOOK
{ FREE-LOCALS ▪ DEFERS END-WORD-HOOK } IS END-WORD-HOOK
{ DEFERS SUSPEND-WORD-HOOK ▪ SUSPEND-LOCALS } IS SUSPEND-WORD-HOOK
{ RESUME-LOCALS ▪ DEFERS RESUME-WORD-HOOK } IS RESUME-WORD-HOOK
FORTH DEFINITIONS FORTH DEFINITIONS
\ Rules: Must be called with nothing else on the return stack (FP = RSP).
\ There is a maximum of eight local variable names (total) in any given scope.
\ LOCALS|…| blocks may be nested so long as nothing else is on the return stack.
\ Space allocated for locals is freed when returning from a word (e.g. with EXIT).
\ The return stack may be used to hold additional data after the LOCALS|…| block.
: LOCALS| ( "<spaces?>name1…<spaces>namen<spaces>|" -- ; xn … x1 -- ) IMMEDIATE : LOCALS| ( "<spaces?>name1…<spaces>namen<spaces>|" -- ; xn … x1 -- ) IMMEDIATE
LOCAL-NAMES ▪ NULL TO LOCAL-NAMES CURRENT-LOCALS @
0 BEGIN BEGIN
PARSE-NAME PARSE-NAME
2DUP "|" COMPARE 0<> 2DUP "|" COMPARE 0<>
WHILE WHILE
@ -2401,15 +2426,11 @@ FORTH DEFINITIONS
LOCAL-NAMES OVER LOCAL>LINK ! LOCAL-NAMES OVER LOCAL>LINK !
2DUP LOCAL>LENGTH ! 2DUP LOCAL>LENGTH !
>R R@ LOCAL>NAME-ADDR SWAP CMOVE >R R@ LOCAL>NAME-ADDR SWAP CMOVE
CURRENT-LOCALS @ R@ LOCAL>INDEX !
1 CURRENT-LOCALS +!
R> TO LOCAL-NAMES R> TO LOCAL-NAMES
1+ REPEAT ▪ 2DROP
REPEAT ▪ 2DROP ▪ POSTPONE LITERAL POSTPONE N>R ; CURRENT-LOCALS @ SWAP - POSTPONE LITERAL POSTPONE N>R POSTPONE RDROP ;
: UNLOCALS IMMEDIATE POSTPONE NRDROP ;
: ENDLOCALS IMMEDIATE
LOCAL-NAMES BEGIN ?DUP WHILE DUP LOCAL>LINK @ SWAP FREE REPEAT
TO LOCAL-NAMES ▪ POSTPONE UNLOCALS ;
SYSTEM DEFINITIONS SYSTEM DEFINITIONS
@ -2656,50 +2677,49 @@ SYSTEM DEFINITIONS
: AA-DELETE-NODE ( x aa-tree aa-node1|NULL -- aa-node2|NULL aa-node3|NULL ) RECURSIVE : AA-DELETE-NODE ( x aa-tree aa-node1|NULL -- aa-node2|NULL aa-node3|NULL ) RECURSIVE
DUP NULL= IF NIP NIP NULL EXIT THEN DUP NULL= IF NIP NIP NULL EXIT THEN
LOCALS| x tree node | LOCALS| x tree node |
x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE
CASE CASE
DUP 0< OF? DROP DUP 0< OF? DROP
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> ! x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
ENDOF ENDOF
DUP 0> OF? DROP DUP 0> OF? DROP
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> ! x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
ENDOF ENDOF
node AA-LEAF? IF DROP node NULL UNLOCALS EXIT THEN node AA-LEAF? IF DROP node NULL EXIT THEN
node AA>LEFT @ NULL= IF node AA>LEFT @ NULL= IF
\ swap current node with its successor in the right subtree \ swap current node with its successor in the right subtree
node AA>RIGHT @ AA>LEFT @ NULL= IF node AA>RIGHT @ AA>LEFT @ NULL= IF
\ right child is the successor \ right child is the successor
node AA>RIGHT @ node AA>RIGHT @
DUP AA>LEVEL node AA>LEVEL EXCHANGE DUP AA>LEVEL node AA>LEVEL EXCHANGE
DUP AA>LEFT node AA>LEFT EXCHANGE DUP AA>LEFT node AA>LEFT EXCHANGE
node SWAP AA>RIGHT XCHG node AA>RIGHT XCHG node! node SWAP AA>RIGHT XCHG node AA>RIGHT XCHG node!
ELSE
\ leftmost descendent of right child is the successor
node AA>RIGHT BEGIN DUP @ AA>LEFT DUP @ WHILE NIP REPEAT DROP
node SWAP XCHG ▪ DUP node AA-EXCHANGE ▪ node!
THEN
\ recurse into right subtree
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
ELSE ELSE
\ swap current node with its predecessor in the left subtree \ leftmost descendent of right child is the successor
node AA>LEFT @ AA>RIGHT @ NULL= IF node AA>RIGHT BEGIN DUP @ AA>LEFT DUP @ WHILE NIP REPEAT DROP
\ left child is the predecessor node SWAP XCHG ▪ DUP node AA-EXCHANGE ▪ node!
node AA>LEFT @
DUP AA>LEVEL node AA>LEVEL EXCHANGE
DUP AA>RIGHT node AA>RIGHT EXCHANGE
node SWAP AA>LEFT XCHG node AA>LEFT XCHG node!
ELSE
\ rightmost descendent of left child is the predecessor
node AA>LEFT BEGIN DUP @ AA>RIGHT DUP @ WHILE NIP REPEAT DROP
node SWAP XCHG ▪ DUP node AA-EXCHANGE ▪ node!
THEN
\ recurse into left subtree
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
THEN THEN
SWAP \ recurse into right subtree
ENDCASE ( S: aa-node2|NULL ) x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
node ELSE
ENDLOCALS \ swap current node with its predecessor in the left subtree
node AA>LEFT @ AA>RIGHT @ NULL= IF
\ left child is the predecessor
node AA>LEFT @
DUP AA>LEVEL node AA>LEVEL EXCHANGE
DUP AA>RIGHT node AA>RIGHT EXCHANGE
node SWAP AA>LEFT XCHG node AA>LEFT XCHG node!
ELSE
\ rightmost descendent of left child is the predecessor
node AA>LEFT BEGIN DUP @ AA>RIGHT DUP @ WHILE NIP REPEAT DROP
node SWAP XCHG ▪ DUP node AA-EXCHANGE ▪ node!
THEN
\ recurse into left subtree
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
THEN
SWAP
ENDCASE ( S: aa-node2|NULL )
node
\ Rebalance the tree \ Rebalance the tree
DUP AA-DECREASE-LEVEL DUP AA-DECREASE-LEVEL
AA-SKEW AA-SKEW
@ -2713,15 +2733,11 @@ SYSTEM DEFINITIONS
: AA-TRAVERSE-NODE ( i*x node-xt null-xt aa-node|NULL -- j*x ) RECURSIVE : AA-TRAVERSE-NODE ( i*x node-xt null-xt aa-node|NULL -- j*x ) RECURSIVE
DUP NULL= IF DROP NIP EXECUTE EXIT THEN DUP NULL= IF DROP NIP EXECUTE EXIT THEN
LOCALS| node-xt null-xt node | LOCALS| node-xt null-xt node |
node-xt node node-xt null-xt node AA>LEFT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE
node-xt null-xt node AA>LEFT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE node-xt null-xt node AA>RIGHT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE
node-xt null-xt node AA>RIGHT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE LOCALS| left-xt right-xt |
ENDLOCALS right-xt node left-xt node-xt EXECUTE
LOCALS| node-xt node left-xt right-xt | left-xt FREE-CLOSURE ▪ right-xt FREE-CLOSURE ;
right-xt node left-xt node-xt EXECUTE
left-xt FREE-CLOSURE
right-xt FREE-CLOSURE
ENDLOCALS ;
UTILITY DEFINITIONS UTILITY DEFINITIONS
@ -2743,14 +2759,13 @@ UTILITY DEFINITIONS
: AA-LOOKUP ( x aa-tree -- aa-node|NULL ) : AA-LOOKUP ( x aa-tree -- aa-node|NULL )
DUP AA>ROOT @ -ROT ▪ DUP AA>COMPARE @ ▪ SWAP AA>VALUE @ DUP AA>ROOT @ -ROT ▪ DUP AA>COMPARE @ ▪ SWAP AA>VALUE @
LOCALS| x compare-xt value-xt | LOCALS| x compare-xt value-xt |
BEGIN BEGIN
DUP DUP
WHILE WHILE
DUP value-xt EXECUTE ▪ x ▪ SWAP compare-xt EXECUTE ▪ ?DUP DUP value-xt EXECUTE ▪ x ▪ SWAP compare-xt EXECUTE ▪ ?DUP
WHILE WHILE
0< IF AA>LEFT ELSE AA>RIGHT THEN @ 0< IF AA>LEFT ELSE AA>RIGHT THEN @
REPEAT REPEAT ;
ENDLOCALS ;
\ node-xt: ( i*x right-xt aa-node left-xt -- j*x ) \ node-xt: ( i*x right-xt aa-node left-xt -- j*x )
\ null-xt: ( i*x -- j*x ) \ null-xt: ( i*x -- j*x )
@ -2857,45 +2872,40 @@ O_RDWR CONSTANT R/W ( -- fam )
: BIN ( fam1 -- fam2 ) IMMEDIATE ; : BIN ( fam1 -- fam2 ) IMMEDIATE ;
: OPEN-FILE ( c-addr u fam -- fileid ) : OPEN-FILE ( c-addr u fam -- fileid )
-ROT MAKE-CSTRING -ROT MAKE-CSTRING ▪ FILE% %ALLOCATE ▪ NULL
open_how% %ALLOCA LOCALS| fam name file open-how |
FILE% %ALLOCATE open_how% %ALLOCA open-how!
LOCALS| fam name open-how file | NULL file FILE>BUFFER !
NULL file FILE>BUFFER ! file CLEAR-LEFTOVER
file CLEAR-LEFTOVER 0# file FILE>POSITION 2!
0# file FILE>POSITION 2! [ NULL 0 ] 2LITERAL file FILE>SOURCE 2!
[ NULL 0 ] 2LITERAL file FILE>SOURCE 2! open-how [[ open_how% %SIZEOF ]] 0 FILL
open-how [[ open_how% %SIZEOF ]] 0 FILL 0 fam open-how open_how>flags 2!
0 fam open-how open_how>flags 2! fam [[ O_CREAT __O_TMPFILE OR ]] AND IF
fam [[ O_CREAT __O_TMPFILE OR ]] AND IF 0 0666 open-how open_how>mode 2!
0 0666 open-how open_how>mode 2! THEN
THEN AT_FDCWD ▪ name ▪ open-how ▪ [[ open_how% %SIZEOF ]]
AT_FDCWD ▪ name ▪ open-how ▪ [[ open_how% %SIZEOF ]] SYS_OPENAT2 SYSCALL4-RETRY
SYS_OPENAT2 SYSCALL4-RETRY name FREE
name FREE DUP ERRNO_ENOENT <> IF ▪ DUP ERRNO_ENOTDIR <> AND-IF ▪ ELSE
DUP ERRNO_ENOENT <> IF ▪ DUP ERRNO_ENOTDIR <> AND-IF ▪ ELSE DROP file FREE EXCP-NON-EXISTENT-FILE THROW
DROP file FREE EXCP-NON-EXISTENT-FILE THROW THEN
THEN DUP 0< IF DROP file FREE EXCP-FILE-IO THROW THEN
DUP 0< IF DROP file FREE EXCP-FILE-IO THROW THEN DUP file FILE>FD !
DUP file FILE>FD ! file FILES AA-LOOKUP NULL<> "internal error - duplicate key in FILES" ?FAIL
file FILES AA-LOOKUP NULL<> "internal error - duplicate key in FILES" ?FAIL file FILES AA-INSERT ;
file FILES AA-INSERT
ENDLOCALS
UNALLOCA ;
: CREATE-FILE ( c-addr u fam -- fileid ) : CREATE-FILE ( c-addr u fam -- fileid )
[[ O_CREAT O_TRUNC OR ]] OR OPEN-FILE ; [[ O_CREAT O_TRUNC OR ]] OR OPEN-FILE ;
: REPOSITION-FILE ( ud fileid -- ) : REPOSITION-FILE ( ud fileid -- )
DUP FD>FILE ▪ signed-long-long% %ALLOCA DUP FD>FILE ▪ NULL
LOCALS| file llseek-result | LOCALS| file llseek-result |
-ROT SWAP ▪ llseek-result ▪ SEEK_SET signed-long-long% %ALLOCA llseek-result!
SYS__LLSEEK SYSCALL5-RETRY -ROT SWAP ▪ llseek-result ▪ SEEK_SET ▪ SYS__LLSEEK SYSCALL5-RETRY
file CLEAR-LEFTOVER file CLEAR-LEFTOVER
0<> IF RDROP EXCP-FILE-IO THROW THEN 0<> IF RDROP EXCP-FILE-IO THROW THEN
llseek-result 2@ SWAP file FILE>POSITION 2! llseek-result 2@ SWAP file FILE>POSITION 2! ;
ENDLOCALS
UNALLOCA ;
: FILE-POSITION ( fileid -- ud ) FD>FILE FILE>POSITION 2@ ; : FILE-POSITION ( fileid -- ud ) FD>FILE FILE>POSITION 2@ ;
@ -2947,32 +2957,30 @@ UTILITY DEFINITIONS
FORTH DEFINITIONS FORTH DEFINITIONS
: READ-FILE ( c-addr u1 fileid -- u2 ) : READ-FILE ( c-addr u1 fileid -- u2 )
FD>FILE LOCALS| addr max file | FD>FILE ▪ LOCALS| addr max file |
0 BEGIN 0 BEGIN
DUP max U< DUP max U<
WHILE WHILE
file (READ-CHAR) file (READ-CHAR)
WHILE WHILE
OVER addr + C! OVER addr + C!
1+ 1+
REPEAT REPEAT ;
ENDLOCALS ;
: READ-LINE ( c-addr u1 fileid -- u2 t=eof ) : READ-LINE ( c-addr u1 fileid -- u2 t=eof )
FD>FILE LOCALS| addr max file | FD>FILE ▪ LOCALS| addr max file |
FALSE 0 BEGIN FALSE 0 BEGIN
DUP max U< DUP max U<
WHILE WHILE
file (READ-CHAR) file (READ-CHAR)
DUP 0= IF >R NIP DUP 0= SWAP R> THEN DUP 0= IF >R NIP DUP 0= SWAP R> THEN
WHILE WHILE
DUP LF <> DUP 0= IF NIP THEN DUP LF <> DUP 0= IF NIP THEN
WHILE WHILE
OVER addr + C! OVER addr + C!
1+ 1+
REPEAT REPEAT
SWAP SWAP ;
ENDLOCALS ;
UTILITY DEFINITIONS UTILITY DEFINITIONS
@ -3051,4 +3059,4 @@ SYSTEM DEFINITIONS
[ INTERACTIVE? ] [IF] BANNER [THEN] [ INTERACTIVE? ] [IF] BANNER [THEN]
} EXECUTE } EXECUTE
( vim:set syntax=jumpforth sw=3 ts=8 et fo-=j: ) ( vim:set syntax=jumpforth sw=3 ts=8 et fo-=j nosi nocin ai ci nojs: )

52
test/aa-tree.4th
View File

@ -10,35 +10,33 @@ ENDSTRUCT SIMPLE%
: MAKE-SIMPLE ( x -- simple-addr ) : MAKE-SIMPLE ( x -- simple-addr )
SIMPLE% %ALLOCATE TUCK SIMPLE>VALUE ! ; SIMPLE% %ALLOCATE TUCK SIMPLE>VALUE ! ;
: SHOW-NODE ( rpre cpre lpre rxt node lxt ) : SHOW-RIGHT-NODE LOCALS| rpre' cpre' lpre' rxt |
LOCALS| rpre cpre lpre rxt node lxt | rpre' cpre' lpre' rxt EXECUTE
node AA>RIGHT @ IF lpre' EXECUTE EOL
rpre { " " TYPE } COMPOSE rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE ;
rpre { " R-" TYPE } COMPOSE
rpre { " | " TYPE } COMPOSE
rxt
LOCALS| rpre' cpre' lpre' rxt |
rpre' cpre' lpre' rxt EXECUTE
lpre' EXECUTE EOL
rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE
ENDLOCALS
THEN
cpre EXECUTE "(" TYPE node AA>LEVEL @ . ") " TYPE : SHOW-LEFT-NODE LOCALS| rpre' cpre' lpre' lxt |
node NODE>SIMPLE SIMPLE>VALUE @ . EOL rpre' EXECUTE EOL
rpre' cpre' lpre' lxt EXECUTE
rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE ;
node AA>LEFT @ IF : SHOW-NODE LOCALS| rpre cpre lpre rxt node lxt |
lpre { " | " TYPE } COMPOSE node AA>RIGHT @ IF
lpre { " L-" TYPE } COMPOSE rpre { " " TYPE } COMPOSE
lpre { " " TYPE } COMPOSE rpre { " R-" TYPE } COMPOSE
lxt rpre { " | " TYPE } COMPOSE
LOCALS| rpre' cpre' lpre' lxt | rxt ▪ SHOW-RIGHT-NODE
rpre' EXECUTE EOL THEN
rpre' cpre' lpre' lxt EXECUTE
rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE cpre EXECUTE "(" TYPE node AA>LEVEL @ . ") " TYPE
ENDLOCALS node NODE>SIMPLE SIMPLE>VALUE @ . EOL
THEN
ENDLOCALS ; node AA>LEFT @ IF
lpre { " | " TYPE } COMPOSE
lpre { " L-" TYPE } COMPOSE
lpre { " " TYPE } COMPOSE
lxt ▪ SHOW-LEFT-NODE
THEN ;
: SHOW-NULL ( rpre cpre lpre -- ) DROP NIP EXECUTE "<empty>\n" TYPE ; : SHOW-NULL ( rpre cpre lpre -- ) DROP NIP EXECUTE "<empty>\n" TYPE ;