diff --git a/jumpforth.S b/jumpforth.S index 4752cec..d3ec609 100644 --- a/jumpforth.S +++ b/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 diff --git a/startup.4th b/startup.4th index 1d65b45..262284b 100644 --- a/startup.4th +++ b/startup.4th @@ -90,7 +90,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) 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 ) 2DROP RDROP EXIT THEN ELSE - DROP-PREFIX + /STRING THEN REPEAT DROP RDROP ; @@ -192,12 +192,19 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) \ Here this is just a LF (Unix convention) but it could be CR (Mac) or CR+LF (DOS) : EOL ( -- "" ) LF EMIT ; +\ Emit n blank (space) characters +: SPACES ( n -- "" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ; + \ Terminate the program, successfully \ This will never return, even if the system call does : BYE ( -- ) 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 -- "" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ; : . ( n -- "" ) 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 ( -- "" ) - SP@ S0 - CELL - 2DUP > IF 2DROP EXIT THEN DUP @ . - BEGIN - CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE . - AGAIN ; +: .S ( -- "" ) + "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 ( -- "" ) \ 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: IF {ELSE } 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 if the condition is false +\ \ This is functionally a short-circuit AND condition +\ \ Without the ELSE they would both branch to +\ IF ONWARD-IF ELSE THEN +\ +\ 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 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: DO LOOP \ DO +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 ; +\ ?DO LOOP +\ ?DO +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 ) 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 ( "" -- ) - BEGIN - PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? THEN - WHILE - SKIP-CHAR - REPEAT ; +\ 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 + 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 ( "" -- ) + 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" -- ) 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 ( "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 - \ 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 + 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 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: "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 ( "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 ( "" | "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 "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 ( -- ) @@ -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 -- "" ) - 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