diff --git a/jumpforth.S b/jumpforth.S index a8aeafa..ffea2d5 100644 --- a/jumpforth.S +++ b/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: */ diff --git a/startup.4th b/startup.4th index 3c99b2a..795ff22 100644 --- a/startup.4th +++ b/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 ( -- "" ) - \ 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 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. "{ }" has the runtime effect \ of placing the execution token for an anonymous function with the runtime \ effect of 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 ( -- ) 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 -- ) - 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| ( "name1…namen|" -- ; 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: ) diff --git a/test/aa-tree.4th b/test/aa-tree.4th index 49a1e20..6f52c0c 100644 --- a/test/aa-tree.4th +++ b/test/aa-tree.4th @@ -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 "\n" TYPE ;