reset RSP to saved frame pointer on exit; eliminates UNLOOP, UNLOCALS, UNALLOCA
This commit is contained in:
parent
c9be49b8a9
commit
35c6641a21
41
jumpforth.S
41
jumpforth.S
|
|
@ -72,6 +72,8 @@ _start:
|
|||
.globl DOCOL
|
||||
DOCOL:
|
||||
PUSHRSP %esi
|
||||
PUSHRSP %edi
|
||||
mov %ebp,%edi
|
||||
movl 4(%eax),%esi
|
||||
NEXT
|
||||
|
||||
|
|
@ -112,8 +114,11 @@ DOLOAD:
|
|||
.balign 4
|
||||
.globl DODOES
|
||||
DODOES:
|
||||
/* Save threaded return address */
|
||||
/* Save threaded return address and frame pointer */
|
||||
PUSHRSP %esi
|
||||
PUSHRSP %edi
|
||||
/* Save the new frame pointer */
|
||||
mov %ebp,%edi
|
||||
/* Load address of DOES> body from DFA into %esi */
|
||||
movl 4(%eax),%esi
|
||||
/* Load address of word body (after DFA) onto stack */
|
||||
|
|
@ -1078,16 +1083,26 @@ defcode NRFETCH,"NR@"
|
|||
mov %edx,%edi
|
||||
NEXT
|
||||
|
||||
/* ( -- a-addr ) */
|
||||
/* ( -- a-addr ) Fetch the return stack pointer */
|
||||
defcode RSPFETCH,"RSP@"
|
||||
push %ebp
|
||||
NEXT
|
||||
|
||||
/* ( a-addr -- ) */
|
||||
/* ( a-addr -- ) Set the return stack pointer */
|
||||
defcode RSPSTORE,"RSP!"
|
||||
pop %ebp
|
||||
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 -- ) */
|
||||
defcode RDROP
|
||||
addl $4,%ebp
|
||||
|
|
@ -1104,6 +1119,14 @@ defcode NRDROP
|
|||
lea (%ebp,%eax,4),%ebp
|
||||
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) */
|
||||
defcode SPFETCH,"SP@"
|
||||
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
|
||||
defcode \fetch_label,\fetch_name
|
||||
pushl ((\idx + 1) * 4)(%ebp)
|
||||
pushl ((\idx + 1) * -4)(%edi)
|
||||
NEXT
|
||||
defcode \store_label,\store_name
|
||||
popl ((\idx + 1) * 4)(%ebp)
|
||||
popl ((\idx + 1) * -4)(%edi)
|
||||
NEXT
|
||||
.endm
|
||||
|
||||
|
|
@ -1166,6 +1189,8 @@ deflocals 6,FETCH_L6,"L6@",STORE_L6,"L6!"
|
|||
deflocals 7,FETCH_L7,"L7@",STORE_L7,"L7!"
|
||||
|
||||
defcode EXIT
|
||||
mov %edi,%ebp
|
||||
POPRSP %edi
|
||||
POPRSP %esi
|
||||
NEXT
|
||||
|
||||
|
|
@ -1537,9 +1562,9 @@ defword INTERPRET,,F_HIDDEN
|
|||
7: .int COMMA,EXIT
|
||||
|
||||
defword QUIT,,F_HIDDEN
|
||||
.int R0,RSPSTORE
|
||||
.int R0,RSPSTORE,LIT,0,FPSTORE
|
||||
0: .int INTERPRET,BRANCH,(0b - .)
|
||||
.int EXIT
|
||||
.int EXIT /* marker only - unreachable */
|
||||
|
||||
defword LATEST,,F_HIDDEN
|
||||
.int CURRENT,FETCH,FETCH,EXIT
|
||||
|
|
@ -1679,3 +1704,5 @@ startup_defs_end:
|
|||
return_stack:
|
||||
.space RETURN_STACK_SIZE
|
||||
return_stack_top:
|
||||
|
||||
/* vim:set syntax=gas: */
|
||||
|
|
|
|||
346
startup.4th
346
startup.4th
|
|
@ -994,11 +994,9 @@ CREATE LEAVE-ORIG NULL ,
|
|||
POSTPONE BEGIN ;
|
||||
: LEAVE ( C: -- ; -- R: limit index -- ) IMMEDIATE
|
||||
LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ;
|
||||
: UNLOOP ( R: limit index -- ) IMMEDIATE
|
||||
POSTPONE 2RDROP ;
|
||||
: +LOOP ( C: outer-stack dest -- ; n -- R: {limit index} -- ) IMMEDIATE
|
||||
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
|
||||
1 POSTPONE LITERAL POSTPONE +LOOP ;
|
||||
' 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
|
||||
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
|
||||
: RDEPTH ( -- n ) R0 RSP@ CELL+ - CELL / ;
|
||||
: RDEPTH ( -- n ) R0 FP@ 2 CELLS+ - CELL / ;
|
||||
|
||||
' SYSTEM (DEFINITIONS)
|
||||
|
||||
|
|
@ -1103,9 +1101,9 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
|
|||
|
||||
\ Display the content of the return stack
|
||||
: .RS ( -- "<text>" )
|
||||
\ Skip the topmost cell, which is the return address for the call to .RS
|
||||
"R(" TYPE RDEPTH 1- . "):" TYPE
|
||||
RSP@ CELL+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN
|
||||
\ Skip the topmost two cells, this call's return address and frame pointer
|
||||
"R(" TYPE RDEPTH 2 - . "):" TYPE
|
||||
FP@ 2 CELLS+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN
|
||||
DUP R0 <> IF " …" TYPE THEN
|
||||
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
|
||||
|
||||
|
|
@ -1221,7 +1219,7 @@ CREATE EXCEPTION-STACK NULL ,
|
|||
EXCEPTION-STACK @ RSP!
|
||||
2R> ▪ [[ ' THROW-UNWIND ]] DEFER! ▪ EXCEPTION-STACK !
|
||||
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)
|
||||
|
||||
|
|
@ -1238,6 +1236,8 @@ CREATE EXCEPTION-STACK NULL ,
|
|||
RSP@
|
||||
\ Save the stack pointer but don't include the xt and RSP on the top
|
||||
SP@ 2 CELLS+ >R
|
||||
\ Save the frame pointer
|
||||
FP@ >R
|
||||
\ Save the input source specification
|
||||
SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R
|
||||
\ 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
|
||||
: (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)
|
||||
|
||||
\ 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 definition is terminated with the ; immediate word, which unhides the name
|
||||
: (:) ( c-addr u -- )
|
||||
(CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ] ;
|
||||
(CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ]
|
||||
BEGIN-WORD-HOOK ;
|
||||
|
||||
' FORTH (DEFINITIONS)
|
||||
|
||||
|
|
@ -1335,12 +1342,14 @@ DEFER REFILL
|
|||
\ where <addr> is the next address after the "EXIT" as a literal number
|
||||
\ Stay in compilation mode for the body of the DOES> clause
|
||||
: 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
|
||||
\ 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 ;
|
||||
END-WORD-HOOK ▪ POSTPONE EXIT POSTPONE [
|
||||
LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ;
|
||||
|
||||
' UTILITY (DEFINITIONS)
|
||||
|
||||
|
|
@ -1465,6 +1474,12 @@ DEFER REFILL
|
|||
: %SIZEOF ( align size -- size ) NIP ;
|
||||
: %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
|
||||
\ 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
|
||||
|
|
@ -1484,9 +1499,10 @@ DEFER REFILL
|
|||
\ Compilation effect: ( C: -- outer-xt orig inner-xt state )
|
||||
\ Interpreter effect: ( S: -- inner-xt state )
|
||||
\ Enters compilation mode if not already compiling
|
||||
: { ( -- {outer-xt orig} inner-xt state ) IMMEDIATE
|
||||
: { ( -- {i*x outer-xt orig} inner-xt state ) IMMEDIATE
|
||||
STATE @
|
||||
DUP IF
|
||||
>R SUSPEND-WORD-HOOK R>
|
||||
LATEST
|
||||
NULL OVER >LINK XCHG LATEST!
|
||||
POSTPONE AHEAD
|
||||
|
|
@ -1501,7 +1517,7 @@ DEFER REFILL
|
|||
\ Resolve the forward branch over the inner function
|
||||
\ Add outer-xt back to the word list after 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 ;
|
||||
IF
|
||||
( S: outer-xt orig inner-xt )
|
||||
|
|
@ -1513,6 +1529,8 @@ DEFER REFILL
|
|||
POSTPONE ]
|
||||
\ Compile inner-xt as a literal in the outer definition
|
||||
POSTPONE LITERAL
|
||||
\ Perform any necessary bookkeeping to compile code in the outer word again
|
||||
RESUME-WORD-HOOK
|
||||
\ ELSE ( nothing to do )
|
||||
( S: inner-xt )
|
||||
THEN ;
|
||||
|
|
@ -1789,32 +1807,17 @@ ENDSTRUCT MEMBLOCK%
|
|||
\ The xt points to the codeword, which is two cells above the base of the object
|
||||
: 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)
|
||||
|
||||
\ 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
|
||||
\ It is assumed that ALLOCATE and ALLOCA (but not ALLOT) return addresses
|
||||
\ suitably aligned for any primitive data type; %ALLOCATE and %ALLOCA are
|
||||
\ 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 ;
|
||||
: %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
|
||||
\ 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
|
||||
: 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' )
|
||||
DUP ▪ BEGIN ▪ DUP WHILE
|
||||
|
|
@ -2254,14 +2257,14 @@ SYSTEM DEFINITIONS
|
|||
FORTH DEFINITIONS
|
||||
|
||||
: 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?
|
||||
|
||||
\ Empty the return stack, make stdin the input source, and enter interpretation state
|
||||
:FINALIZE QUIT ( -- <noreturn> )
|
||||
CATCHING? IF EXCP-QUIT THROW THEN
|
||||
R0 RSP!
|
||||
R0 RSP! ▪ NULL FP!
|
||||
0 CURRENT-SOURCE-ID !
|
||||
FALSE STATE !
|
||||
BEGIN
|
||||
|
|
@ -2287,7 +2290,7 @@ REVERT
|
|||
DUP HASHCELL ▪ DUP #REPORTERS + SWAP ?DO
|
||||
I #REPORTERS 1- AND ▪ REPORTERS
|
||||
2DUP 2@ SWAP -ROT = TUCK SWAP NULL= OR IF
|
||||
ROT DROP UNLOOP EXIT
|
||||
ROT DROP EXIT
|
||||
THEN ▪ 2DROP
|
||||
LOOP ▪ DROP NULL FALSE ;
|
||||
|
||||
|
|
@ -2331,7 +2334,7 @@ SYSTEM DEFINITIONS
|
|||
{ "Uninitialized deferred word\n" TYPE } EXCP-DEFER-UNINITIALIZED REPORTER!
|
||||
|
||||
: 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
|
||||
|
||||
\ Switch to the interpreter defined in this startup file
|
||||
|
|
@ -2351,6 +2354,7 @@ SYSTEM DEFINITIONS
|
|||
|
||||
STRUCT
|
||||
CELL% FIELD LOCAL>LINK
|
||||
CELL% FIELD LOCAL>INDEX
|
||||
CELL% FIELD LOCAL>LENGTH
|
||||
CHAR% 0 * FIELD LOCAL>NAME-ADDR
|
||||
ENDSTRUCT LOCAL%
|
||||
|
|
@ -2361,6 +2365,8 @@ ENDSTRUCT LOCAL%
|
|||
: LOCAL>NAME ( local -- c-addr u ) DUP LOCAL>NAME-ADDR SWAP LOCAL>LENGTH @ ;
|
||||
|
||||
NULL VALUE LOCAL-NAMES
|
||||
VARIABLE CURRENT-LOCALS
|
||||
0 CURRENT-LOCALS !
|
||||
|
||||
8 CONSTANT #LOCALS
|
||||
#LOCALS ARRAY LOCAL-FETCHERS
|
||||
|
|
@ -2373,27 +2379,46 @@ MARKER REVERT
|
|||
REVERT
|
||||
|
||||
: LOCAL-INDEX ( c-addr u1 -- u2 TRUE | FALSE )
|
||||
LOCAL-NAMES #LOCALS 0 ?DO
|
||||
DUP NULL= IF LEAVE THEN
|
||||
>R 2DUP R@ LOCAL>NAME COMPARE R> SWAP 0= IF
|
||||
DROP 2DROP I TRUE UNLOOP EXIT
|
||||
2>R ▪ LOCAL-NAMES ▪ BEGIN ▪ ?DUP WHILE
|
||||
DUP LOCAL>NAME 2R@ COMPARE 0= IF
|
||||
2RDROP LOCAL>INDEX @ TRUE EXIT
|
||||
THEN
|
||||
LOCAL>LINK @
|
||||
LOOP ▪ DROP ▪ 2DROP ▪ FALSE ;
|
||||
REPEAT ▪ 2RDROP ▪ FALSE ;
|
||||
|
||||
: LOCAL-LOOKUP ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
|
||||
2DUP FALSE >R
|
||||
DUP 1 > IF ▪ 2DUP + 1- C@ [[ CHAR ! ]] = IF ▪ 1- RDROP TRUE >R ▪ THEN ▪ 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 ;
|
||||
|
||||
{ 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
|
||||
|
||||
\ 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
|
||||
LOCAL-NAMES ▪ NULL TO LOCAL-NAMES
|
||||
0 BEGIN
|
||||
CURRENT-LOCALS @
|
||||
BEGIN
|
||||
PARSE-NAME
|
||||
2DUP "|" COMPARE 0<>
|
||||
WHILE
|
||||
|
|
@ -2401,15 +2426,11 @@ FORTH DEFINITIONS
|
|||
LOCAL-NAMES OVER LOCAL>LINK !
|
||||
2DUP LOCAL>LENGTH !
|
||||
>R R@ LOCAL>NAME-ADDR SWAP CMOVE
|
||||
CURRENT-LOCALS @ R@ LOCAL>INDEX !
|
||||
1 CURRENT-LOCALS +!
|
||||
R> TO LOCAL-NAMES
|
||||
1+
|
||||
REPEAT ▪ 2DROP ▪ POSTPONE LITERAL POSTPONE N>R ;
|
||||
|
||||
: UNLOCALS IMMEDIATE POSTPONE NRDROP ;
|
||||
|
||||
: ENDLOCALS IMMEDIATE
|
||||
LOCAL-NAMES BEGIN ?DUP WHILE DUP LOCAL>LINK @ SWAP FREE REPEAT
|
||||
TO LOCAL-NAMES ▪ POSTPONE UNLOCALS ;
|
||||
REPEAT ▪ 2DROP
|
||||
CURRENT-LOCALS @ SWAP - POSTPONE LITERAL POSTPONE N>R POSTPONE RDROP ;
|
||||
|
||||
SYSTEM DEFINITIONS
|
||||
|
||||
|
|
@ -2656,50 +2677,49 @@ SYSTEM DEFINITIONS
|
|||
: AA-DELETE-NODE ( x aa-tree aa-node1|NULL -- aa-node2|NULL aa-node3|NULL ) RECURSIVE
|
||||
DUP NULL= IF NIP NIP NULL EXIT THEN
|
||||
LOCALS| x tree node |
|
||||
x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE
|
||||
CASE
|
||||
DUP 0< OF? DROP
|
||||
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
|
||||
ENDOF
|
||||
DUP 0> OF? DROP
|
||||
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
|
||||
ENDOF
|
||||
node AA-LEAF? IF DROP node NULL UNLOCALS EXIT THEN
|
||||
node AA>LEFT @ NULL= IF
|
||||
\ swap current node with its successor in the right subtree
|
||||
node AA>RIGHT @ AA>LEFT @ NULL= IF
|
||||
\ right child is the successor
|
||||
node AA>RIGHT @
|
||||
DUP AA>LEVEL node AA>LEVEL EXCHANGE
|
||||
DUP AA>LEFT node AA>LEFT EXCHANGE
|
||||
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> !
|
||||
x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE
|
||||
CASE
|
||||
DUP 0< OF? DROP
|
||||
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
|
||||
ENDOF
|
||||
DUP 0> OF? DROP
|
||||
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
|
||||
ENDOF
|
||||
node AA-LEAF? IF DROP node NULL EXIT THEN
|
||||
node AA>LEFT @ NULL= IF
|
||||
\ swap current node with its successor in the right subtree
|
||||
node AA>RIGHT @ AA>LEFT @ NULL= IF
|
||||
\ right child is the successor
|
||||
node AA>RIGHT @
|
||||
DUP AA>LEVEL node AA>LEVEL EXCHANGE
|
||||
DUP AA>LEFT node AA>LEFT EXCHANGE
|
||||
node SWAP AA>RIGHT XCHG node AA>RIGHT XCHG node!
|
||||
ELSE
|
||||
\ 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> !
|
||||
\ 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
|
||||
SWAP
|
||||
ENDCASE ( S: aa-node2|NULL )
|
||||
node
|
||||
ENDLOCALS
|
||||
\ recurse into right subtree
|
||||
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
|
||||
ELSE
|
||||
\ 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
|
||||
DUP AA-DECREASE-LEVEL
|
||||
AA-SKEW
|
||||
|
|
@ -2713,15 +2733,11 @@ SYSTEM DEFINITIONS
|
|||
: AA-TRAVERSE-NODE ( i*x node-xt null-xt aa-node|NULL -- j*x ) RECURSIVE
|
||||
DUP NULL= IF DROP NIP EXECUTE EXIT THEN
|
||||
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>RIGHT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE
|
||||
ENDLOCALS
|
||||
LOCALS| node-xt node left-xt right-xt |
|
||||
right-xt node left-xt node-xt EXECUTE
|
||||
left-xt FREE-CLOSURE
|
||||
right-xt FREE-CLOSURE
|
||||
ENDLOCALS ;
|
||||
node-xt null-xt node AA>LEFT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE
|
||||
node-xt null-xt node AA>RIGHT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE
|
||||
LOCALS| left-xt right-xt |
|
||||
right-xt node left-xt node-xt EXECUTE
|
||||
left-xt FREE-CLOSURE ▪ right-xt FREE-CLOSURE ;
|
||||
|
||||
UTILITY DEFINITIONS
|
||||
|
||||
|
|
@ -2743,14 +2759,13 @@ UTILITY DEFINITIONS
|
|||
: AA-LOOKUP ( x aa-tree -- aa-node|NULL )
|
||||
DUP AA>ROOT @ -ROT ▪ DUP AA>COMPARE @ ▪ SWAP AA>VALUE @
|
||||
LOCALS| x compare-xt value-xt |
|
||||
BEGIN
|
||||
DUP
|
||||
WHILE
|
||||
DUP value-xt EXECUTE ▪ x ▪ SWAP compare-xt EXECUTE ▪ ?DUP
|
||||
WHILE
|
||||
0< IF AA>LEFT ELSE AA>RIGHT THEN @
|
||||
REPEAT
|
||||
ENDLOCALS ;
|
||||
BEGIN
|
||||
DUP
|
||||
WHILE
|
||||
DUP value-xt EXECUTE ▪ x ▪ SWAP compare-xt EXECUTE ▪ ?DUP
|
||||
WHILE
|
||||
0< IF AA>LEFT ELSE AA>RIGHT THEN @
|
||||
REPEAT ;
|
||||
|
||||
\ node-xt: ( i*x right-xt aa-node left-xt -- j*x )
|
||||
\ null-xt: ( i*x -- j*x )
|
||||
|
|
@ -2857,45 +2872,40 @@ O_RDWR CONSTANT R/W ( -- fam )
|
|||
: BIN ( fam1 -- fam2 ) IMMEDIATE ;
|
||||
|
||||
: OPEN-FILE ( c-addr u fam -- fileid )
|
||||
-ROT MAKE-CSTRING
|
||||
open_how% %ALLOCA
|
||||
FILE% %ALLOCATE
|
||||
LOCALS| fam name open-how file |
|
||||
NULL file FILE>BUFFER !
|
||||
file CLEAR-LEFTOVER
|
||||
0# file FILE>POSITION 2!
|
||||
[ NULL 0 ] 2LITERAL file FILE>SOURCE 2!
|
||||
open-how [[ open_how% %SIZEOF ]] 0 FILL
|
||||
0 fam open-how open_how>flags 2!
|
||||
fam [[ O_CREAT __O_TMPFILE OR ]] AND IF
|
||||
0 0666 open-how open_how>mode 2!
|
||||
THEN
|
||||
AT_FDCWD ▪ name ▪ open-how ▪ [[ open_how% %SIZEOF ]]
|
||||
SYS_OPENAT2 SYSCALL4-RETRY
|
||||
name FREE
|
||||
DUP ERRNO_ENOENT <> IF ▪ DUP ERRNO_ENOTDIR <> AND-IF ▪ ELSE
|
||||
DROP file FREE EXCP-NON-EXISTENT-FILE THROW
|
||||
THEN
|
||||
DUP 0< IF DROP file FREE EXCP-FILE-IO THROW THEN
|
||||
DUP file FILE>FD !
|
||||
file FILES AA-LOOKUP NULL<> "internal error - duplicate key in FILES" ?FAIL
|
||||
file FILES AA-INSERT
|
||||
ENDLOCALS
|
||||
UNALLOCA ;
|
||||
-ROT MAKE-CSTRING ▪ FILE% %ALLOCATE ▪ NULL
|
||||
LOCALS| fam name file open-how |
|
||||
open_how% %ALLOCA open-how!
|
||||
NULL file FILE>BUFFER !
|
||||
file CLEAR-LEFTOVER
|
||||
0# file FILE>POSITION 2!
|
||||
[ NULL 0 ] 2LITERAL file FILE>SOURCE 2!
|
||||
open-how [[ open_how% %SIZEOF ]] 0 FILL
|
||||
0 fam open-how open_how>flags 2!
|
||||
fam [[ O_CREAT __O_TMPFILE OR ]] AND IF
|
||||
0 0666 open-how open_how>mode 2!
|
||||
THEN
|
||||
AT_FDCWD ▪ name ▪ open-how ▪ [[ open_how% %SIZEOF ]]
|
||||
SYS_OPENAT2 SYSCALL4-RETRY
|
||||
name FREE
|
||||
DUP ERRNO_ENOENT <> IF ▪ DUP ERRNO_ENOTDIR <> AND-IF ▪ ELSE
|
||||
DROP file FREE EXCP-NON-EXISTENT-FILE THROW
|
||||
THEN
|
||||
DUP 0< IF DROP file FREE EXCP-FILE-IO THROW THEN
|
||||
DUP file FILE>FD !
|
||||
file FILES AA-LOOKUP NULL<> "internal error - duplicate key in FILES" ?FAIL
|
||||
file FILES AA-INSERT ;
|
||||
|
||||
: CREATE-FILE ( c-addr u fam -- fileid )
|
||||
[[ O_CREAT O_TRUNC OR ]] OR OPEN-FILE ;
|
||||
|
||||
: REPOSITION-FILE ( ud fileid -- )
|
||||
DUP FD>FILE ▪ signed-long-long% %ALLOCA
|
||||
LOCALS| file llseek-result |
|
||||
-ROT SWAP ▪ llseek-result ▪ SEEK_SET
|
||||
SYS__LLSEEK SYSCALL5-RETRY
|
||||
file CLEAR-LEFTOVER
|
||||
0<> IF RDROP EXCP-FILE-IO THROW THEN
|
||||
llseek-result 2@ SWAP file FILE>POSITION 2!
|
||||
ENDLOCALS
|
||||
UNALLOCA ;
|
||||
DUP FD>FILE ▪ NULL
|
||||
LOCALS| file llseek-result |
|
||||
signed-long-long% %ALLOCA llseek-result!
|
||||
-ROT SWAP ▪ llseek-result ▪ SEEK_SET ▪ SYS__LLSEEK SYSCALL5-RETRY
|
||||
file CLEAR-LEFTOVER
|
||||
0<> IF RDROP EXCP-FILE-IO THROW THEN
|
||||
llseek-result 2@ SWAP file FILE>POSITION 2! ;
|
||||
|
||||
: FILE-POSITION ( fileid -- ud ) FD>FILE FILE>POSITION 2@ ;
|
||||
|
||||
|
|
@ -2947,32 +2957,30 @@ UTILITY DEFINITIONS
|
|||
FORTH DEFINITIONS
|
||||
|
||||
: READ-FILE ( c-addr u1 fileid -- u2 )
|
||||
FD>FILE LOCALS| addr max file |
|
||||
0 BEGIN
|
||||
DUP max U<
|
||||
WHILE
|
||||
file (READ-CHAR)
|
||||
WHILE
|
||||
OVER addr + C!
|
||||
1+
|
||||
REPEAT
|
||||
ENDLOCALS ;
|
||||
FD>FILE ▪ LOCALS| addr max file |
|
||||
0 BEGIN
|
||||
DUP max U<
|
||||
WHILE
|
||||
file (READ-CHAR)
|
||||
WHILE
|
||||
OVER addr + C!
|
||||
1+
|
||||
REPEAT ;
|
||||
|
||||
: READ-LINE ( c-addr u1 fileid -- u2 t=eof )
|
||||
FD>FILE LOCALS| addr max file |
|
||||
FALSE 0 BEGIN
|
||||
DUP max U<
|
||||
WHILE
|
||||
file (READ-CHAR)
|
||||
DUP 0= IF >R NIP DUP 0= SWAP R> THEN
|
||||
WHILE
|
||||
DUP LF <> DUP 0= IF NIP THEN
|
||||
WHILE
|
||||
OVER addr + C!
|
||||
1+
|
||||
REPEAT
|
||||
SWAP
|
||||
ENDLOCALS ;
|
||||
FD>FILE ▪ LOCALS| addr max file |
|
||||
FALSE 0 BEGIN
|
||||
DUP max U<
|
||||
WHILE
|
||||
file (READ-CHAR)
|
||||
DUP 0= IF >R NIP DUP 0= SWAP R> THEN
|
||||
WHILE
|
||||
DUP LF <> DUP 0= IF NIP THEN
|
||||
WHILE
|
||||
OVER addr + C!
|
||||
1+
|
||||
REPEAT
|
||||
SWAP ;
|
||||
|
||||
UTILITY DEFINITIONS
|
||||
|
||||
|
|
@ -3051,4 +3059,4 @@ SYSTEM DEFINITIONS
|
|||
[ INTERACTIVE? ] [IF] BANNER [THEN]
|
||||
} 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: )
|
||||
|
|
|
|||
|
|
@ -10,35 +10,33 @@ ENDSTRUCT SIMPLE%
|
|||
: MAKE-SIMPLE ( x -- simple-addr )
|
||||
SIMPLE% %ALLOCATE TUCK SIMPLE>VALUE ! ;
|
||||
|
||||
: SHOW-NODE ( rpre cpre lpre rxt node lxt )
|
||||
LOCALS| rpre cpre lpre rxt node lxt |
|
||||
node AA>RIGHT @ IF
|
||||
rpre { " " TYPE } COMPOSE
|
||||
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
|
||||
: SHOW-RIGHT-NODE LOCALS| rpre' cpre' lpre' rxt |
|
||||
rpre' cpre' lpre' rxt EXECUTE
|
||||
lpre' EXECUTE EOL
|
||||
rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE ;
|
||||
|
||||
cpre EXECUTE "(" TYPE node AA>LEVEL @ . ") " TYPE
|
||||
node NODE>SIMPLE SIMPLE>VALUE @ . EOL
|
||||
: SHOW-LEFT-NODE LOCALS| rpre' cpre' lpre' lxt |
|
||||
rpre' EXECUTE EOL
|
||||
rpre' cpre' lpre' lxt EXECUTE
|
||||
rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE ;
|
||||
|
||||
node AA>LEFT @ IF
|
||||
lpre { " | " TYPE } COMPOSE
|
||||
lpre { " L-" TYPE } COMPOSE
|
||||
lpre { " " TYPE } COMPOSE
|
||||
lxt
|
||||
LOCALS| rpre' cpre' lpre' lxt |
|
||||
rpre' EXECUTE EOL
|
||||
rpre' cpre' lpre' lxt EXECUTE
|
||||
rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE
|
||||
ENDLOCALS
|
||||
THEN
|
||||
ENDLOCALS ;
|
||||
: SHOW-NODE LOCALS| rpre cpre lpre rxt node lxt |
|
||||
node AA>RIGHT @ IF
|
||||
rpre { " " TYPE } COMPOSE
|
||||
rpre { " R-" TYPE } COMPOSE
|
||||
rpre { " | " TYPE } COMPOSE
|
||||
rxt ▪ SHOW-RIGHT-NODE
|
||||
THEN
|
||||
|
||||
cpre EXECUTE "(" TYPE node AA>LEVEL @ . ") " TYPE
|
||||
node NODE>SIMPLE SIMPLE>VALUE @ . EOL
|
||||
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue