implement LEAVE, [IF]…[ELSE]…[THEN], and various other changes
This commit is contained in:
parent
77607934cd
commit
447c212f09
22
jumpforth.S
22
jumpforth.S
|
|
@ -237,7 +237,7 @@ defconst SYS_GETPID,__NR_getpid
|
|||
defconst SYS_BRK,__NR_brk
|
||||
/* defconst SYS_SIGNAL,__NR_signal */
|
||||
/* defconst SYS_UMOUNT2,__NR_umount2 */
|
||||
/* defconst SYS_IOCTL,__NR_ioctl */
|
||||
defconst SYS_IOCTL,__NR_ioctl
|
||||
/* defconst SYS_SETPGID,__NR_setpgid */
|
||||
/* defconst SYS_UMASK,__NR_umask */
|
||||
/* defconst SYS_CHROOT,__NR_chroot */
|
||||
|
|
@ -1226,6 +1226,14 @@ defcode DECREMENT,"-!"
|
|||
subl %eax,(%ebx)
|
||||
NEXT
|
||||
|
||||
/* ( x1 a-addr -- x2 ) Store x1 in the cell at a-addr and return the old value */
|
||||
defcode XCHG
|
||||
pop %eax
|
||||
mov (%eax),%ebx
|
||||
popl (%eax)
|
||||
push %ebx
|
||||
NEXT
|
||||
|
||||
defcode TWOSTORE,"2!"
|
||||
pop %ebx
|
||||
popl (%ebx)
|
||||
|
|
@ -1238,6 +1246,18 @@ defcode TWOFETCH,"2@"
|
|||
pushl (%ebx)
|
||||
NEXT
|
||||
|
||||
/* ( xd1 a-addr -- xd2 ) Store xd1 in the double-cell a-addr; return the old value */
|
||||
/* Equivalent to: DUP 2@ 2>R 2! 2R> */
|
||||
defcode TWOXCHG,"2XCHG"
|
||||
pop %eax
|
||||
mov 4(%eax),%ebx
|
||||
mov (%eax),%ecx
|
||||
popl (%eax)
|
||||
popl 4(%eax)
|
||||
push %ebx
|
||||
push %ecx
|
||||
NEXT
|
||||
|
||||
/* ( c-addr u char -- ) Fill u characters starting at c-addr with char */
|
||||
defcode FILL
|
||||
pop %eax
|
||||
|
|
|
|||
377
startup.4th
377
startup.4th
|
|
@ -90,7 +90,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
SP@ 2DUP C! STDOUT SWAP 1 SYS_WRITE SYSCALL3 2DROP ;
|
||||
|
||||
\ Decrement the array size and increment the address by the same amount
|
||||
: DROP-PREFIX ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ;
|
||||
: /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ;
|
||||
|
||||
\ Write a character array to the given file descriptor
|
||||
\ Repeat write syscall until entire string is written
|
||||
|
|
@ -106,7 +106,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
2DROP RDROP EXIT
|
||||
THEN
|
||||
ELSE
|
||||
DROP-PREFIX
|
||||
/STRING
|
||||
THEN
|
||||
REPEAT
|
||||
DROP RDROP ;
|
||||
|
|
@ -192,12 +192,19 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
\ Here this is just a LF (Unix convention) but it could be CR (Mac) or CR+LF (DOS)
|
||||
: EOL ( -- "<eol>" ) LF EMIT ;
|
||||
|
||||
\ Emit n blank (space) characters
|
||||
: SPACES ( n -- "<spaces>" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ;
|
||||
|
||||
\ Terminate the program, successfully
|
||||
\ This will never return, even if the system call does
|
||||
: BYE ( -- <noreturn> )
|
||||
BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ;
|
||||
|
||||
\ With 32-bit cells, a double-cell number has 64 bits
|
||||
\ Space is reserved for binary output with a leading minus sign and a trailing space
|
||||
\ The minimum pictured numeric output buffer size is thus 66 bytes
|
||||
80 CONSTANT PNO-BUFFER-BYTES
|
||||
|
||||
CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT
|
||||
PNO-BUFFER PNO-BUFFER-BYTES + CONSTANT PNO-BUFFER-END
|
||||
CREATE PNO-POINTER PNO-BUFFER-END ,
|
||||
|
|
@ -213,11 +220,7 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
|
|||
: SIGN ( n -- ) 0< IF [CHAR] - HOLD THEN ;
|
||||
|
||||
: #B ( ud1 u -- ud2 )
|
||||
UM/MOD ROT DUP 10 >= IF
|
||||
10 - [CHAR] A +
|
||||
ELSE
|
||||
[CHAR] 0 +
|
||||
THEN HOLD ;
|
||||
UM/MOD ROT DUP 10 >= IF 10 - [CHAR] A + ELSE [CHAR] 0 + THEN HOLD ;
|
||||
|
||||
: # ( ud1 -- ud2 ) 10 #B ;
|
||||
|
||||
|
|
@ -234,22 +237,26 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
|
|||
: D. ( d -- "<minus?><digits>" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ;
|
||||
: . ( n -- "<minus?><digits>" ) S>D D. ;
|
||||
|
||||
\ Return the number of words on the data and return stacks, respectively
|
||||
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
|
||||
: RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ;
|
||||
|
||||
CREATE DISPLAY-ITEM-LIMIT 6 ,
|
||||
|
||||
\ Display the content of the data stack
|
||||
: .DS ( -- "<text>" )
|
||||
SP@ S0
|
||||
CELL - 2DUP > IF 2DROP EXIT THEN DUP @ .
|
||||
BEGIN
|
||||
CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE .
|
||||
AGAIN ;
|
||||
: .S ( -- "<text>" )
|
||||
"S(" TYPE DEPTH . "):" TYPE
|
||||
SP@ DUP DISPLAY-ITEM-LIMIT @ CELLS+ S0 UMIN
|
||||
DUP S0 <> IF " …" TYPE THEN
|
||||
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
|
||||
|
||||
\ Display the content of the return stack
|
||||
: .RS ( -- "<text>" )
|
||||
\ Skip the topmost cell, which is the return address for the call to .RS
|
||||
RSP@ CELL + R0
|
||||
CELL - 2DUP > IF 2DROP EXIT THEN DUP @ .
|
||||
BEGIN
|
||||
CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE .
|
||||
AGAIN ;
|
||||
"R(" TYPE RDEPTH 1- . "):" TYPE
|
||||
RSP@ CELL+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN
|
||||
DUP R0 <> IF " …" TYPE THEN
|
||||
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
|
||||
|
||||
\ Return the next address in the compilation/data area
|
||||
: HERE ( -- addr ) CP @ ;
|
||||
|
|
@ -315,7 +322,7 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
|
|||
\ Our first control-flow primitive: <cond> IF <true> {ELSE <false>} THEN
|
||||
\
|
||||
\ IF compiles an unresolved conditional branch.
|
||||
\ AHEAD compiles an unconditional branch (same effect as TRUE IF).
|
||||
\ AHEAD compiles an unconditional branch (same effect as FALSE IF).
|
||||
\ Both AHEAD and IF leave the address of the unresolved offset on the stack.
|
||||
\
|
||||
\ THEN consumes the offset address and resolves it to the next code address.
|
||||
|
|
@ -323,12 +330,35 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
|
|||
\ ELSE inserts an unconditional branch (to THEN) and also resolves the
|
||||
\ previous forward reference (from IF).
|
||||
\
|
||||
: IF ( C: -- orig ) ( Runtime S: flag -- ) IMMEDIATE
|
||||
POSTPONE 0BRANCH HERE 0 , ;
|
||||
: AHEAD ( C: -- orig ) IMMEDIATE
|
||||
POSTPONE BRANCH HERE 0 , ;
|
||||
\ Via ONWARD-IF and ONWARD-AHEAD the unresolve branch offset cell may be used
|
||||
\ as the link field of a linked list to connect multiple forward branches to
|
||||
\ the same THEN. When THEN is executed it will follow the links and update all
|
||||
\ the connected branches to the same location. The list is terminated with zero
|
||||
\ in the link field. Example:
|
||||
\
|
||||
\ \ The IF and ONWARD-IF both branch to <code2> if the condition is false
|
||||
\ \ This is functionally a short-circuit AND condition
|
||||
\ \ Without the ELSE they would both branch to <code3>
|
||||
\ <cond1> IF <cond2> ONWARD-IF <code1> ELSE <code2> THEN <code3>
|
||||
\
|
||||
\ ALWAYS is provided as a placeholder; it has the same effect as TRUE IF but
|
||||
\ includes no branch. The "orig" value it leaves on the stack (zero) is ignored
|
||||
\ by THEN and marks the end of the list if consumed by ONWARD-IF or ONWARD-AHEAD.
|
||||
\ This can be used as a base for control structures with zero or more branches.
|
||||
\
|
||||
\ The low-level primitives:
|
||||
: ALWAYS ( C: -- orig ) IMMEDIATE 0 ;
|
||||
: ONWARD-IF ( C: orig1 -- orig2 ) IMMEDIATE
|
||||
POSTPONE 0BRANCH HERE SWAP , ;
|
||||
: ONWARD-AHEAD ( C: orig1 -- orig2 ) IMMEDIATE
|
||||
POSTPONE BRANCH HERE SWAP , ;
|
||||
: THEN ( C: orig -- ) IMMEDIATE
|
||||
HERE OVER - SWAP ! ;
|
||||
BEGIN ?DUP WHILE HERE OVER - SWAP XCHG REPEAT ;
|
||||
\ The derived control structures:
|
||||
: IF ( C: -- orig ) ( Runtime S: flag -- ) IMMEDIATE
|
||||
POSTPONE ALWAYS POSTPONE ONWARD-IF ;
|
||||
: AHEAD ( C: -- orig ) IMMEDIATE
|
||||
POSTPONE ALWAYS POSTPONE ONWARD-AHEAD ;
|
||||
: ELSE ( C: orig1 -- orig2 ) IMMEDIATE
|
||||
POSTPONE AHEAD SWAP POSTPONE THEN ;
|
||||
|
||||
|
|
@ -372,38 +402,65 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
|
|||
\ with the number of references on top. Inside OF ... ENDOF there is additionally
|
||||
\ a forward reference to the ENDOF (as with IF ... THEN) above the ENDCASE counter.
|
||||
\
|
||||
\ Begin by creating a counter for the number of unresolved ENDOF forward references
|
||||
\ Begin by creating a placeholder for the unresolved ENDOF forward references
|
||||
: CASE ( C: -- 0 ) IMMEDIATE
|
||||
0 ;
|
||||
POSTPONE ALWAYS ;
|
||||
\ At runtime compare the values on the top of the stack; branch to ENDOF if unequal
|
||||
\ Keep the first value for the next OF if unequal, otherwise consume both
|
||||
: OF ( C: orign ... orig1 n -- orign ... orig1 n orig-of ) IMMEDIATE
|
||||
POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ;
|
||||
\ Create a forward branch to ENDCASE and resolve the one from OF
|
||||
: ENDOF ( C: orign ... orig1 n orig-of -- orign ... orig1 orig0 n+1 ) IMMEDIATE
|
||||
POSTPONE AHEAD -ROT POSTPONE THEN 1+ ;
|
||||
: ENDOF ( C: orig-case1 orig-of -- orig-case2 ) IMMEDIATE
|
||||
SWAP POSTPONE ONWARD-AHEAD SWAP POSTPONE THEN ;
|
||||
\ Drop the <x> value in case none of the OF...ENDOF clauses matched
|
||||
\ Resolve all the forward branches from ENDOF to the location after ENDCASE
|
||||
: ENDCASE ( C: orign ... orig1 n -- ) IMMEDIATE
|
||||
POSTPONE DROP BEGIN ?DUP WHILE 1- SWAP POSTPONE THEN REPEAT ;
|
||||
: ENDCASE ( C: orig-case -- ) IMMEDIATE
|
||||
POSTPONE DROP POSTPONE THEN ;
|
||||
|
||||
\ Range loop: <limit> <index> DO <code> LOOP
|
||||
\ <limit> <index> DO <code> <step> +LOOP
|
||||
: UNLOOP POSTPONE 2RDROP ; IMMEDIATE
|
||||
: DO POSTPONE 2>R POSTPONE BEGIN ; IMMEDIATE
|
||||
: (+LOOP) ( step limit index -- flag limit index' )
|
||||
ROT + 2DUP = -ROT ;
|
||||
: +LOOP IMMEDIATE
|
||||
POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R
|
||||
POSTPONE UNTIL POSTPONE 2RDROP ;
|
||||
' (+LOOP) (HIDE)
|
||||
: LOOP IMMEDIATE 1 POSTPONE LITERAL POSTPONE +LOOP ;
|
||||
\ <limit> <index> ?DO <code> LOOP
|
||||
\ <limit> <index> ?DO <code> <step> +LOOP
|
||||
CREATE LEAVE-ORIG 0 ,
|
||||
: DO ( C: -- outer-stack dest S: limit index R: -- limit index ) IMMEDIATE
|
||||
POSTPONE 2>R LEAVE-ORIG @
|
||||
POSTPONE ALWAYS LEAVE-ORIG !
|
||||
POSTPONE BEGIN ;
|
||||
: ?DO ( C: -- outer-stack dest S: limit index R: -- limit index ) IMMEDIATE
|
||||
POSTPONE 2>R LEAVE-ORIG @
|
||||
POSTPONE 2R@ POSTPONE <> POSTPONE IF LEAVE-ORIG !
|
||||
POSTPONE BEGIN ;
|
||||
: LEAVE ( C: -- S: -- R: limit index -- ) IMMEDIATE
|
||||
LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ;
|
||||
: UNLOOP ( R: limit index -- ) IMMEDIATE
|
||||
POSTPONE 2RDROP ;
|
||||
: +LOOP ( C: outer-stack dest -- S: n -- R: {limit index} -- ) IMMEDIATE
|
||||
POSTPONE RSP@ POSTPONE +! POSTPONE 2R@ POSTPONE = POSTPONE UNTIL
|
||||
LEAVE-ORIG @ POSTPONE THEN POSTPONE UNLOOP LEAVE-ORIG ! ;
|
||||
: LOOP ( C: outer-stack dest -- S: -- R: {limit index} -- ) IMMEDIATE
|
||||
1 POSTPONE LITERAL POSTPONE +LOOP ;
|
||||
' LEAVE-ORIG (HIDE)
|
||||
|
||||
\ Return the current index value from the innermost or next-innermost loop.
|
||||
\ The loops must be directly nested with no other changes to the return stack
|
||||
: I 1 RPICK ;
|
||||
: J 3 RPICK ;
|
||||
|
||||
\ Remove trailing whitespace from a string (only affects length)
|
||||
: -TRAILING ( c-addr u1 -- c-addr u2 )
|
||||
BEGIN DUP AND-THEN 2DUP 1- + C@ SPACE? THEN WHILE 1- REPEAT ;
|
||||
|
||||
\ Return -1, 0, or 1 if the left string is respectively
|
||||
\ less than, equal to, or greater than the right string
|
||||
: COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 )
|
||||
ROT SWAP 2DUP - >R UMIN 0 ?DO
|
||||
( S: c-addr1 c-addr2 R: u1-u2 loop-sys )
|
||||
OVER I + C@ OVER I + C@
|
||||
( S: c-addr1 c-addr2 ch1 ch2 )
|
||||
- ?DUP IF NIP NIP SIGNUM UNLOOP RDROP EXIT THEN
|
||||
LOOP
|
||||
2DROP R> SIGNUM ;
|
||||
|
||||
\ This function defines what happens when THROW is used outside of any CATCH
|
||||
: DEFAULT-UNWIND ( k*x n -- i*x <noreturn> )
|
||||
CASE
|
||||
|
|
@ -446,7 +503,7 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
|||
: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
|
||||
: RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ;
|
||||
|
||||
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ DROP-PREFIX ;
|
||||
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ;
|
||||
|
||||
: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ;
|
||||
|
||||
|
|
@ -457,12 +514,66 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
|||
|
||||
: NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ;
|
||||
|
||||
: SKIPSPACE ( "<spaces?>" -- )
|
||||
\ The size of this buffer will determine the maximum line length
|
||||
4096 CONSTANT TERMINAL-BUFFER-SIZE
|
||||
CREATE TERMINAL-BUFFER TERMINAL-BUFFER-SIZE ALLOT
|
||||
|
||||
\ If we read more than one line then these will refer to the rest of the data
|
||||
CREATE TIB-LEFTOVER 0 ,
|
||||
CREATE TIB-LEFTOVER-SIZE 0 ,
|
||||
|
||||
\ Attempt to replace the parse area with the next line from the current source
|
||||
\ Return TRUE if the parse area was refilled, or FALSE otherwise
|
||||
\ REFILL always fails if the current source is a string (from EVALUATE)
|
||||
: REFILL ( -- flag )
|
||||
SOURCE-ID 0< IF FALSE EXIT THEN
|
||||
\ Shift any leftover characters after the previous line to the start of the buffer
|
||||
TIB-LEFTOVER @ TERMINAL-BUFFER TIB-LEFTOVER-SIZE @ CMOVE
|
||||
\ Look for the linefeed character which marks the end of the first line
|
||||
TIB-LEFTOVER-SIZE @ 0 BEGIN
|
||||
\ If at the end with room in the buffer, read more from the file descriptor
|
||||
2DUP = IF
|
||||
DUP TERMINAL-BUFFER-SIZE U< IF
|
||||
\ SOURCE-ID is the file descriptor number to read from
|
||||
SOURCE-ID OVER DUP TERMINAL-BUFFER + SWAP TERMINAL-BUFFER-SIZE SWAP -
|
||||
( S: length idx src-id buff buff-size )
|
||||
\ Repeat read if interrupted by a signal (returns -EINTR)
|
||||
BEGIN
|
||||
PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? THEN
|
||||
WHILE
|
||||
SKIP-CHAR
|
||||
REPEAT ;
|
||||
SYS_READ SYSCALL3
|
||||
DUP ERRNO_EINTR NEGATE <>
|
||||
UNTIL
|
||||
\ Any other negative (error) return value is fatal
|
||||
DUP 0< IF EXCP-FILE-IO THROW THEN
|
||||
( S: length idx u-read )
|
||||
\ Add the amount of data read to the length; index is unchanged
|
||||
ROT + SWAP
|
||||
THEN
|
||||
THEN
|
||||
\ At this point if index equals length then buffer is full or read returned 0
|
||||
\ Either way, we won't be reading any more into the buffer
|
||||
2DUP = OR-ELSE
|
||||
\ Check if the next character is a linefeed
|
||||
1+ DUP 1- TERMINAL-BUFFER + C@ LF =
|
||||
THEN
|
||||
UNTIL
|
||||
( S: length idx )
|
||||
\ idx is the next location after the linefeed, if found, or else equal to length
|
||||
\ Save the rest, if any, for the next REFILL
|
||||
DUP TERMINAL-BUFFER + TIB-LEFTOVER !
|
||||
TUCK - TIB-LEFTOVER-SIZE !
|
||||
( S: idx )
|
||||
\ The new input buffer is the first idx characters of the terminal buffer
|
||||
TERMINAL-BUFFER INPUT-BUFFER !
|
||||
DUP INPUT-BUFFER-SIZE !
|
||||
DUP IF 0 >IN ! THEN
|
||||
0<> ;
|
||||
|
||||
' TIB-LEFTOVER (HIDE)
|
||||
' TIB-LEFTOVER-SIZE (HIDE)
|
||||
' TERMINAL-BUFFER (HIDE)
|
||||
|
||||
: SKIP-SPACES ( "<spaces?>" -- )
|
||||
BEGIN PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? DUP IF SKIP-CHAR THEN 0= THEN UNTIL ;
|
||||
|
||||
\ Comments; ignore all characters until the next EOL or ) character, respectively
|
||||
: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
|
||||
|
|
@ -471,10 +582,15 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
|||
\ Skip whitespace; read and return the next word delimited by whitespace
|
||||
\ The delimiting whitespace character is left in the parse area
|
||||
: WORD ( "<spaces>ccc" -- c-addr u )
|
||||
SKIPSPACE
|
||||
BEGIN
|
||||
SKIP-SPACES
|
||||
PARSE-EMPTY?
|
||||
WHILE
|
||||
REFILL 0= IF 0 0 EXIT THEN
|
||||
REPEAT
|
||||
PARSE-AREA DROP
|
||||
BEGIN
|
||||
PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? THEN 0=
|
||||
PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? 0= THEN
|
||||
WHILE
|
||||
SKIP-CHAR
|
||||
REPEAT
|
||||
|
|
@ -500,7 +616,7 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
|||
|
||||
' (DOES) (HIDE)
|
||||
|
||||
: (MARK) TYPE ": " TYPE .DS EOL ;
|
||||
: (MARK) "-- " TYPE TYPE " --\n" TYPE .S R> .RS >R ;
|
||||
: MARK IMMEDIATE WORD POSTPONE SLITERAL POSTPONE (MARK) ;
|
||||
' (MARK) (HIDE)
|
||||
|
||||
|
|
@ -555,7 +671,7 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
|||
CREATE CELLS 2* ALLOT DOES> SWAP [ 2 CELLS ] LITERAL * + ;
|
||||
|
||||
\ Define a threaded word which also displays its name and the data stack when called
|
||||
: (TRACE) >NAME TYPE SPACE .DS EOL ;
|
||||
: (TRACE) >NAME TYPE SPACE .S ;
|
||||
: :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ;
|
||||
' (TRACE) (HIDE)
|
||||
|
||||
|
|
@ -587,7 +703,7 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
|||
\ LATEST always refers to the innermost enclosing definition.
|
||||
\
|
||||
\ Example:
|
||||
\ > : TIMES 0 DO DUP EXECUTE LOOP DROP ;
|
||||
\ > : TIMES 0 ?DO DUP EXECUTE LOOP DROP ;
|
||||
\ > : GREETINGS { "Hello" TYPE EOL } 3 TIMES ;
|
||||
\ > GREETINGS
|
||||
\ Hello
|
||||
|
|
@ -630,6 +746,40 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
|||
( S: inner-xt )
|
||||
THEN ;
|
||||
|
||||
\ Conditional compilation
|
||||
\ No effect if flag is true, otherwise skips words until matching [ELSE] or [THEN]
|
||||
\ Skips over nested [IF] … [THEN] or [IF] … [ELSE] … [THEN] structures
|
||||
: [IF] IMMEDIATE RECURSIVE
|
||||
0= IF
|
||||
0 BEGIN
|
||||
WORD 2>R
|
||||
2R@ "[IF]" COMPARE 0= IF
|
||||
1+
|
||||
ELSE 2R@ "[THEN]" COMPARE 0= OR-ELSE 2R@ "[ELSE]" COMPARE 0= THEN IF
|
||||
?DUP 0= IF 2RDROP EXIT THEN
|
||||
1-
|
||||
THEN THEN
|
||||
2RDROP
|
||||
AGAIN
|
||||
THEN ;
|
||||
|
||||
\ Skips words until matching [THEN]
|
||||
\ Skips over nested [IF] … [THEN] or [IF] … [ELSE] … [THEN] structures
|
||||
: [ELSE] IMMEDIATE
|
||||
0 BEGIN
|
||||
WORD 2>R
|
||||
2R@ "[IF]" COMPARE 0= IF
|
||||
1+
|
||||
ELSE 2R@ "[THEN]" COMPARE 0= IF
|
||||
?DUP 0= IF 2RDROP EXIT THEN
|
||||
1-
|
||||
THEN THEN
|
||||
2RDROP
|
||||
AGAIN ;
|
||||
|
||||
\ [THEN] is just a placeholder to terminate [IF] or [ELSE]; no compilation effect
|
||||
: [THEN] IMMEDIATE ;
|
||||
|
||||
4096 CONSTANT PAGESIZE
|
||||
|
||||
0 CONSTANT PROT_NONE
|
||||
|
|
@ -648,7 +798,7 @@ BUDDY-ORDERS 1- BUDDY-ORDER-BYTES CONSTANT BUDDY-MAX-BYTES
|
|||
BUDDY-ORDERS ARRAY BUDDY-HEADS
|
||||
|
||||
: INIT-BUDDY-HEADS ( -- )
|
||||
BUDDY-ORDERS 0 DO 0 I BUDDY-HEADS ! LOOP ;
|
||||
BUDDY-ORDERS 0 ?DO 0 I BUDDY-HEADS ! LOOP ;
|
||||
|
||||
INIT-BUDDY-HEADS
|
||||
|
||||
|
|
@ -666,14 +816,14 @@ INIT-BUDDY-HEADS
|
|||
THEN
|
||||
( S: order head-addr block-addr ) ( R: freed-addr )
|
||||
2 PICK 1+ BUDDY-ORDERS < AND-THEN
|
||||
DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = AND-THEN
|
||||
DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ =
|
||||
THEN AND-THEN
|
||||
\ Found the buddy on the free list; coalesce
|
||||
@ SWAP !
|
||||
\ Pick the lower (naturally aligned) block address
|
||||
DUP BUDDY-ORDER-BYTES INVERT R> AND >R
|
||||
\ Repeat process with the next-higher order
|
||||
1+ DUP BUDDY-HEADS TRUE
|
||||
THEN
|
||||
THEN 0= IF
|
||||
\ Insert before first item with address >= this addr
|
||||
DUP R@ U>= IF R@ ! R> SWAP ! DROP EXIT THEN
|
||||
|
|
@ -723,7 +873,6 @@ VARIABLE TOTAL
|
|||
|
||||
: ALLOCATE ( size -- a-addr )
|
||||
CELL+ DUP BUDDY-MAX-BYTES U> IF
|
||||
MARK A
|
||||
BEGIN
|
||||
NULL OVER PROT_READ PROT_WRITE OR
|
||||
MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6
|
||||
|
|
@ -733,7 +882,6 @@ MARK A
|
|||
REPEAT
|
||||
TUCK ! CELL+ EXIT
|
||||
THEN
|
||||
MARK B
|
||||
NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN
|
||||
BUDDY-ORDER-FROM-BYTES DUP BUDDY-ALLOCATE SWAP OVER ! CELL+ ;
|
||||
|
||||
|
|
@ -753,34 +901,6 @@ MARK B
|
|||
: [CHAR] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- c ) IMMEDIATE
|
||||
CHAR POSTPONE LITERAL ;
|
||||
|
||||
\ Return -1, 0, or 1 if the left string is respectively
|
||||
\ less than, equal to, or greater than the right string
|
||||
: COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 )
|
||||
BEGIN
|
||||
ROT ?DUP IF
|
||||
( S: a1 a2 u2 u1 )
|
||||
SWAP ?DUP IF
|
||||
( S: a1 a2 u1 u2 )
|
||||
2SWAP 2DUP C@ SWAP C@ - DUP IF
|
||||
>R 4 NDROP R> SIGNUM EXIT
|
||||
ELSE
|
||||
DROP
|
||||
( S: u1 u2 a1 a2 )
|
||||
1+ SWAP 1+ 2SWAP 1- SWAP 1-
|
||||
( S: a2' a1' u2' u1' )
|
||||
SWAP -ROT 2SWAP
|
||||
( S: a1' u1' a2' u2' )
|
||||
THEN
|
||||
ELSE
|
||||
\ Return 1 since first string is longer
|
||||
DROP 2DROP 1 EXIT
|
||||
THEN
|
||||
ELSE
|
||||
\ If u2 is also zero return 0; else return -1 since first string is shorter
|
||||
-ROT 2DROP 0<> EXIT
|
||||
THEN
|
||||
AGAIN ;
|
||||
|
||||
\ Field accessors for the search order linked list
|
||||
: ORDER>LINK ( a-addr1 -- a-addr2 ) ;
|
||||
: ORDER>WID ( a-addr1 -- a-addr2 ) CELL+ ;
|
||||
|
|
@ -962,61 +1082,6 @@ VARIABLE ORDER-FREELIST
|
|||
: :REPLACE ( "<spaces>ccc" -- )
|
||||
: LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ;
|
||||
|
||||
\ The size of this buffer will determine the maximum line length
|
||||
4096 CONSTANT TERMINAL-BUFFER-SIZE
|
||||
CREATE TERMINAL-BUFFER TERMINAL-BUFFER-SIZE ALLOT
|
||||
|
||||
\ If we read more than one line then these will refer to the rest of the data
|
||||
CREATE TIB-LEFTOVER 0 ,
|
||||
CREATE TIB-LEFTOVER-SIZE 0 ,
|
||||
|
||||
: REFILL ( -- flag )
|
||||
SOURCE-ID 0< IF FALSE EXIT THEN
|
||||
\ Shift any leftover characters after the previous line to the start of the buffer
|
||||
TIB-LEFTOVER @ TERMINAL-BUFFER TIB-LEFTOVER-SIZE @ CMOVE
|
||||
\ Look for the linefeed character which marks the end of the first line
|
||||
TIB-LEFTOVER-SIZE @ 0 BEGIN
|
||||
\ If at the end with room in the buffer, read more from the file descriptor
|
||||
2DUP = IF
|
||||
DUP TERMINAL-BUFFER-SIZE U< IF
|
||||
\ SOURCE-ID is the file descriptor number to read from
|
||||
SOURCE-ID OVER DUP TERMINAL-BUFFER + SWAP TERMINAL-BUFFER-SIZE SWAP -
|
||||
( S: length idx src-id buff buff-size )
|
||||
\ Repeat read if interrupted by a signal (returns -EINTR)
|
||||
BEGIN
|
||||
SYS_READ SYSCALL3
|
||||
DUP ERRNO_EINTR NEGATE <>
|
||||
UNTIL
|
||||
\ Any other negative (error) return value is fatal
|
||||
DUP 0< IF EXCP-FILE-IO THROW THEN
|
||||
( S: length idx u-read )
|
||||
\ Add the amount of data read to the length; index is unchanged
|
||||
ROT + SWAP
|
||||
THEN
|
||||
THEN
|
||||
\ At this point if index equals length then buffer is full or read returned 0
|
||||
\ Either way, we won't be reading any more into the buffer
|
||||
2DUP = OR-ELSE
|
||||
\ Check if the next character is a linefeed
|
||||
1+ DUP 1- TERMINAL-BUFFER + C@ LF =
|
||||
THEN
|
||||
UNTIL
|
||||
( S: length idx )
|
||||
\ idx is the next location after the linefeed, if found, or else equal to length
|
||||
\ Save the rest, if any, for the next REFILL
|
||||
DUP TERMINAL-BUFFER + TIB-LEFTOVER !
|
||||
TUCK - TIB-LEFTOVER-SIZE !
|
||||
( S: idx )
|
||||
\ The new input buffer is the first idx characters of the terminal buffer
|
||||
TERMINAL-BUFFER INPUT-BUFFER !
|
||||
DUP INPUT-BUFFER-SIZE !
|
||||
DUP IF 0 >IN ! THEN
|
||||
0<> ;
|
||||
|
||||
HIDE TIB-LEFTOVER
|
||||
HIDE TIB-LEFTOVER-SIZE
|
||||
HIDE TERMINAL-BUFFER
|
||||
|
||||
: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
|
||||
NEXT-CHAR DUP [CHAR] \ = IF
|
||||
DROP NEXT-CHAR CASE
|
||||
|
|
@ -1066,14 +1131,13 @@ HIDE TERMINAL-BUFFER
|
|||
REPEAT
|
||||
( S: neg-flag accum c-addr' ) ( R: c-addr u )
|
||||
2RDROP DROP SWAP IF NEGATE THEN
|
||||
TRUE
|
||||
;
|
||||
TRUE ;
|
||||
|
||||
\ Read a word, number, or string and either execute it or compile it
|
||||
\ The stack effect depends on the input and the current value of STATE
|
||||
: INTERPRET ( i*x "<spaces>ccc" -- j*x )
|
||||
BEGIN
|
||||
SKIPSPACE
|
||||
SKIP-SPACES
|
||||
PARSE-EMPTY? 0=
|
||||
WHILE
|
||||
PEEK-CHAR [CHAR] " = IF
|
||||
|
|
@ -1103,6 +1167,15 @@ HIDE TERMINAL-BUFFER
|
|||
DEFER SHOW-PROMPT
|
||||
{ "> " TYPE } IS SHOW-PROMPT
|
||||
|
||||
36 CONSTANT STRUCT-TERMIOS-BYTES
|
||||
21505 CONSTANT IOCTL_TCGETS
|
||||
CREATE TERMIOS STRUCT-TERMIOS-BYTES ALLOT ALIGN
|
||||
|
||||
: TTY? ( fd -- flag )
|
||||
IOCTL_TCGETS TERMIOS SYS_IOCTL SYSCALL3 0= ;
|
||||
|
||||
STDIN TTY? CONSTANT INTERACTIVE?
|
||||
|
||||
\ Redefine QUIT as a non-deferred word; update deferred references to point here
|
||||
\ Empty the return stack, make stdin the input source, and enter interpretation state
|
||||
:REPLACE QUIT ( -- <noreturn> )
|
||||
|
|
@ -1110,14 +1183,12 @@ DEFER SHOW-PROMPT
|
|||
0 CURRENT-SOURCE-ID !
|
||||
FALSE STATE !
|
||||
BEGIN
|
||||
SHOW-PROMPT
|
||||
REFILL 0= IF
|
||||
EOL BYE
|
||||
THEN
|
||||
[ INTERACTIVE? ] [IF] SHOW-PROMPT [THEN]
|
||||
REFILL 0= IF BYE THEN
|
||||
INTERPRET
|
||||
STATE @ 0= IF
|
||||
"OK\n" TYPE
|
||||
THEN
|
||||
[ INTERACTIVE? ] [IF]
|
||||
STATE @ 0= IF "OK\n" TYPE THEN
|
||||
[THEN]
|
||||
AGAIN ;
|
||||
|
||||
: EVALUATE ( i*x c-addr u -- j*x )
|
||||
|
|
@ -1208,9 +1279,6 @@ DEFINITIONS
|
|||
\ From this point on we only execute threaded FORTH words defined in this file
|
||||
\ *****************************************************************************
|
||||
|
||||
\ Return the number of words on the data stack
|
||||
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
|
||||
|
||||
\ Return TRUE if the given address is the execution token of a word in
|
||||
\ the current search order or compilation word list, or FALSE otherwise
|
||||
\ The word's name may be hidden or shadowed by another definition
|
||||
|
|
@ -1259,7 +1327,7 @@ DEFINITIONS
|
|||
|
||||
\ Display a string in escaped (double-quoted) format, without the delimiters
|
||||
: TYPE-ESCAPED ( c-addr u -- "<escapeseq*>" )
|
||||
0 DO DUP 1+ SWAP C@ CASE
|
||||
0 ?DO DUP 1+ SWAP C@ CASE
|
||||
0 OF "\\0" TYPE ENDOF
|
||||
7 OF "\\a" TYPE ENDOF
|
||||
8 OF "\\b" TYPE ENDOF
|
||||
|
|
@ -1362,7 +1430,10 @@ HIDE NONAME-LITERAL?
|
|||
|
||||
HIDE UNTHREAD
|
||||
|
||||
: WORDS ( -- )
|
||||
GET-ORDER ?DUP IF 1- SWAP >R NDROP R> SHOW-WORDLIST THEN ;
|
||||
|
||||
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
|
||||
|
||||
BANNER
|
||||
INTERACTIVE? [IF] BANNER [THEN]
|
||||
QUIT
|
||||
|
|
|
|||
Loading…
Reference in New Issue