revise the input system to better align with ANS FORTH
This commit is contained in:
parent
3ae2ff353b
commit
c0391de969
209
jumpforth.S
209
jumpforth.S
|
|
@ -6,7 +6,6 @@
|
|||
|
||||
.set JUMPFORTH_VERSION,1
|
||||
|
||||
.set BUFFER_SIZE,4096
|
||||
.set RETURN_STACK_SIZE,8192
|
||||
|
||||
.set DATA_SEGMENT_INITIAL_SIZE,65536
|
||||
|
|
@ -185,9 +184,6 @@ defconst VERSION,JUMPFORTH_VERSION
|
|||
|
||||
defconst R0,return_stack_top
|
||||
|
||||
defconst BUFFER,buffer
|
||||
defconst __BUFFER_SIZE,BUFFER_SIZE,"BUFFER_SIZE"
|
||||
|
||||
defconst __DOCOL,DOCOL,"DOCOL"
|
||||
defconst __DODATA,DODATA,"DODATA"
|
||||
defconst __DOLOAD,DOLOAD,"DOLOAD"
|
||||
|
|
@ -616,13 +612,11 @@ defconst SIGABRT,6
|
|||
defvalue C0 /* first byte of the heap */
|
||||
defvalue S0 /* initial (empty) data stack pointer */
|
||||
|
||||
/* STATE controls whether we are currently executing code (0) or compiling (1) */
|
||||
defvar STATE,0 /* default to executing code */
|
||||
/* STATE controls whether we are currently interpreting (0) or compiling (1) */
|
||||
defvar STATE,0 /* default to interpreting */
|
||||
|
||||
/* Initially the KEY function "reads" the embedded file "startup.4th". */
|
||||
/* When this is exhausted the pointers are reset to point to the input buffer. */
|
||||
defvar CURRKEY,startup_defs
|
||||
defvar BUFFTOP,startup_defs_end
|
||||
/* >IN gives the current offset of the parse area within the input buffer */
|
||||
defvar IN,0,">IN"
|
||||
|
||||
/* NOTE: These are initialized in _start but vary during runtime. */
|
||||
defvar CP /* "compilation pointer", next free byte in the heap */
|
||||
|
|
@ -1051,7 +1045,7 @@ defcode FILL
|
|||
rep stosb
|
||||
NEXT
|
||||
|
||||
/* ( src dst n -- ) ( block copy n bytes from src to dst ) */
|
||||
/* ( src dst n -- ) Block copy n bytes from src to dst (ascending addresses) */
|
||||
defcode CMOVE
|
||||
mov %esi,%edx
|
||||
pop %ecx
|
||||
|
|
@ -1061,6 +1055,20 @@ defcode CMOVE
|
|||
mov %edx,%esi
|
||||
NEXT
|
||||
|
||||
/* ( src dst n -- ) Block copy n bytes from src to dst (descending addresses) */
|
||||
defcode CMOVE_UP,"CMOVE>"
|
||||
mov %esi,%edx
|
||||
pop %ecx
|
||||
pop %edi
|
||||
pop %esi
|
||||
lea -1(%edi,%ecx),%edi
|
||||
lea -1(%esi,%ecx),%esi
|
||||
std
|
||||
rep movsb
|
||||
cld
|
||||
mov %edx,%esi
|
||||
NEXT
|
||||
|
||||
/* ( a -- ) ( R: -- a ) */
|
||||
defcode TOR,">R"
|
||||
pop %eax
|
||||
|
|
@ -1101,7 +1109,7 @@ defcode TWOFROMR,"2R>"
|
|||
push %ebx
|
||||
NEXT
|
||||
|
||||
/* (R: a b -- a b ) ( -- a b ) */
|
||||
/* ( R: a b -- a b ) ( -- a b ) */
|
||||
defcode TWORFETCH,"2R@"
|
||||
movl (%ebp),%ebx
|
||||
movl 4(%ebp),%eax
|
||||
|
|
@ -1109,27 +1117,77 @@ defcode TWORFETCH,"2R@"
|
|||
push %ebx
|
||||
NEXT
|
||||
|
||||
/* ( xu ... x1 u -- ) ( R: -- xu ... x1 u ) */
|
||||
defcode NTOR,"N>R"
|
||||
mov %esi,%edx
|
||||
movl (%esp),%ecx
|
||||
add $1,%ecx
|
||||
mov %ecx,%ebx
|
||||
shl $2,%ebx
|
||||
sub %ebx,%ebp
|
||||
mov %esp,%esi
|
||||
mov %ebp,%edi
|
||||
rep movsd
|
||||
mov %esi,%esp
|
||||
mov %edx,%esi
|
||||
NEXT
|
||||
|
||||
/* ( R: xu ... x1 u -- ) ( -- xu ... x1 u ) */
|
||||
defcode NFROMR,"NR>"
|
||||
mov %esi,%edx
|
||||
movl (%ebp),%ecx
|
||||
add $1,%ecx
|
||||
mov %ecx,%ebx
|
||||
shl $2,%ebx
|
||||
sub %ebx,%esp
|
||||
mov %ebp,%esi
|
||||
mov %esp,%edi
|
||||
rep movsd
|
||||
mov %esi,%ebp
|
||||
mov %edx,%esi
|
||||
NEXT
|
||||
|
||||
/* ( R: xu ... x1 u -- xu ... x1 u ) ( -- xu ... x1 u ) */
|
||||
defcode NRFETCH,"NR@"
|
||||
mov %esi,%edx
|
||||
movl (%ebp),%ecx
|
||||
add $1,%ecx
|
||||
mov %ecx,%ebx
|
||||
shl $2,%ebx
|
||||
sub %ebx,%esp
|
||||
mov %ebp,%esi
|
||||
mov %esp,%edi
|
||||
rep movsd
|
||||
mov %edx,%esi
|
||||
NEXT
|
||||
|
||||
/* ( -- a-addr ) */
|
||||
defcode RSPFETCH,"RSP@"
|
||||
push %ebp
|
||||
NEXT
|
||||
|
||||
/* ( a-addr -- ) */
|
||||
defcode RSPSTORE,"RSP!"
|
||||
pop %ebp
|
||||
NEXT
|
||||
|
||||
/* ( R: x -- ) */
|
||||
defcode RDROP
|
||||
addl $4,%ebp
|
||||
NEXT
|
||||
|
||||
/* ( R: a b -- ) */
|
||||
defcode TWORDROP,"2RDROP"
|
||||
addl $8,%ebp
|
||||
NEXT
|
||||
|
||||
/* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */
|
||||
defcode SPFETCH,"SP@"
|
||||
mov %esp,%eax
|
||||
push %eax
|
||||
NEXT
|
||||
|
||||
/* ( a-addr -- ) Set the data stack pointer */
|
||||
defcode SPSTORE,"SP!"
|
||||
pop %esp
|
||||
NEXT
|
||||
|
|
@ -1257,12 +1315,17 @@ defcode BREAK
|
|||
.section .data
|
||||
bootstrap_data_begin:
|
||||
|
||||
/* ( c-addr u -- "ccc" ) */
|
||||
defword TYPE
|
||||
.int LIT,1,NROT,SYS_WRITE,SYSCALL3,DROP,EXIT
|
||||
|
||||
/* ( c -- "c" ) */
|
||||
defword EMIT
|
||||
.int SPFETCH,LIT,1,SWAP,LIT,1,SYS_WRITE,SYSCALL3,TWODROP,EXIT
|
||||
|
||||
/* ( -- "<eol>" ) */
|
||||
defword EOL
|
||||
litstring "\n"
|
||||
.int TYPE,EXIT
|
||||
.int LIT,10,EMIT,EXIT
|
||||
|
||||
/* Used for any fatal errors that occur during bootstrapping */
|
||||
defword BAILOUT
|
||||
|
|
@ -1271,33 +1334,43 @@ defword BAILOUT
|
|||
.int TYPE
|
||||
0: .int LIT,254,SYS_EXIT,SYSCALL1,DROP,BRANCH,(0b - .)
|
||||
|
||||
/* Simplified KEY that can only read from the pre-filled input buffer */
|
||||
/* The startup.4th should replace this with a more complete version */
|
||||
/* If the input ends while this version is still in use the program will terminate */
|
||||
defword KEY
|
||||
.int CURRKEY,FETCH,DUP,BUFFTOP,FETCH,GE,ZBRANCH,(1f - .)
|
||||
litstring "Unexpected end of buffer\n"
|
||||
defword UNEXPECTED_EOF,"UNEXPECTED-EOF"
|
||||
litstring "Unexpected end of input\n"
|
||||
.int TYPE,BAILOUT
|
||||
1: .int DUP,ADD1,CURRKEY,STORE,FETCHBYTE,EXIT
|
||||
|
||||
/* Puts the most recently read key back in the input buffer */
|
||||
/* CAUTION: Can only safely be used ONCE after each call to KEY! */
|
||||
defword PUTBACK
|
||||
.int CURRKEY,FETCH,SUB1,CURRKEY,STORE,EXIT
|
||||
/* During bootstrapping the source buffer is the embedded file "startup.4th". */
|
||||
/* ( -- c-addr u ) */
|
||||
defword SOURCE
|
||||
.int LIT,startup_defs,LIT,(startup_defs_end - startup_defs),EXIT
|
||||
|
||||
/* ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) */
|
||||
defword DROP_PREFIX,"DROP-PREFIX"
|
||||
.int ROT,OVER,ADD,NROT,SUB,EXIT
|
||||
|
||||
/* ( -- c-addr u ) Current parse area (input buffer minus first >IN characters) */
|
||||
defword PARSE_AREA,"PARSE-AREA"
|
||||
.int SOURCE,IN,FETCH,DROP_PREFIX,EXIT
|
||||
|
||||
/* ( "c" -- c ) Leaves c at the start of the parse area */
|
||||
defword PEEK_CHAR,"PEEK-CHAR"
|
||||
.int PARSE_AREA,ZBRANCH,(0f - .),FETCHBYTE,EXIT
|
||||
0: .int UNEXPECTED_EOF
|
||||
|
||||
/* ( "c" -- c ) Removes and returns the first character in the parse area */
|
||||
defword NEXT_CHAR,"NEXT-CHAR"
|
||||
.int PEEK_CHAR,LIT,1,IN,INCREMENT,EXIT
|
||||
|
||||
/* ( c -- flag ) */
|
||||
defword ISSPACE,"SPACE?"
|
||||
/* check for space (32) first and return true if input matches */
|
||||
.int DUP,LIT,32,EQU,QDUP,ZBRANCH,(0f - .),NIP,EXIT
|
||||
/* otherwise test for 9...13 inclusive (HT, LF, VT, FF, CR) */
|
||||
0: .int LIT,9,SUB,LIT,(13 - 9),ULT,EXIT
|
||||
|
||||
defword SKIPSPACE
|
||||
0: .int KEY,ISSPACE,ZEQU,ZBRANCH,(0b - .),PUTBACK,EXIT
|
||||
|
||||
/* Simplified version that can only work within the preallocated data region */
|
||||
/* The startup.4th should replace this with a more complete version */
|
||||
defword ALLOT
|
||||
.int CP,FETCH,ADD,CP,STORE,EXIT
|
||||
.int CP,INCREMENT,EXIT
|
||||
|
||||
defword COMMA,","
|
||||
.int CP,FETCH,CELL,ALLOT,STORE,EXIT
|
||||
|
|
@ -1399,19 +1472,47 @@ defword FIND_OR_ABORT,"FIND-OR-ABORT"
|
|||
0: litstring "Word not found: "
|
||||
.int TYPE,TYPE,EOL,BAILOUT
|
||||
|
||||
/* ( "<spaces>" -- ) */
|
||||
defword SKIPSPACE
|
||||
0: .int PARSE_AREA,ZBRANCH,(1f - .)
|
||||
.int FETCHBYTE,ISSPACE,ZBRANCH,(2f - .)
|
||||
.int LIT,1,IN,INCREMENT,BRANCH,(0b - .)
|
||||
1: .int DROP
|
||||
2: .int EXIT
|
||||
|
||||
/* ( "<spaces?>ccc" -- c-addr u ) */
|
||||
defword WORD
|
||||
.int SKIPSPACE,CP,FETCH
|
||||
0: .int KEY,DUP,ISSPACE,ZBRANCH,(1f - .)
|
||||
.int DROP,PUTBACK,CP,FETCH,OVER,SUB,OVER,CP,STORE,EXIT
|
||||
1: .int COMMABYTE,BRANCH,(0b - .)
|
||||
.int SKIPSPACE
|
||||
.int PARSE_AREA,DROP,LIT,1
|
||||
.int NEXT_CHAR,DROP
|
||||
0: .int PARSE_AREA,ZBRANCH,(1f - .)
|
||||
.int FETCHBYTE,ISSPACE,ZEQU,ZBRANCH,(2f - .)
|
||||
.int ADD1,LIT,1,IN,INCREMENT,BRANCH,(0b - .)
|
||||
1: .int DROP
|
||||
2: .int EXIT
|
||||
|
||||
defword ESCAPED_CHAR
|
||||
.int NEXT_CHAR,DUP,LIT,'\\',NEQU,ZBRANCH,(0f - .),EXIT
|
||||
0: .int DROP,NEXT_CHAR
|
||||
.int LIT,'0',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,0,EXIT
|
||||
0: .int LIT,'a',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,7,EXIT
|
||||
0: .int LIT,'b',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,8,EXIT
|
||||
0: .int LIT,'t',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,9,EXIT
|
||||
0: .int LIT,'n',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,10,EXIT
|
||||
0: .int LIT,'v',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,11,EXIT
|
||||
0: .int LIT,'f',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,12,EXIT
|
||||
0: .int LIT,'r',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,13,EXIT
|
||||
0: .int LIT,34,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,34,EXIT /* double-quote */
|
||||
0: .int LIT,39,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,39,EXIT /* single-quote */
|
||||
0: .int LIT,92,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,92,EXIT /* backslash */
|
||||
0: litstring "Unknown escape sequence: \\"
|
||||
.int TYPE,EMIT,EOL,BAILOUT
|
||||
|
||||
defword READSTRING
|
||||
.int CP,FETCH
|
||||
0: .int KEY,DUP,LIT,'\\',EQU,ZBRANCH,(1f - .)
|
||||
.int DROP,KEY,BRANCH,(2f - .)
|
||||
1: .int DUP,LIT,'"',EQU,ZBRANCH,(2f - .)
|
||||
.int DROP,CP,FETCH,OVER,SUB,ALIGN,EXIT
|
||||
2: .int COMMABYTE,BRANCH,(0b - .)
|
||||
0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .)
|
||||
.int ESCAPED_CHAR,COMMABYTE,BRANCH,(0b - .)
|
||||
1: .int LIT,1,IN,INCREMENT,CP,FETCH,OVER,SUB,ALIGN,EXIT
|
||||
|
||||
defword PARSENUMBER
|
||||
.int DUP,LIT,0,GT,ZBRANCH,(6f - .)
|
||||
|
|
@ -1431,15 +1532,15 @@ defword PARSENUMBER
|
|||
|
||||
defword INTERPRET
|
||||
.int SKIPSPACE
|
||||
.int KEY,LIT,'"',EQU,ZBRANCH,(1f - .)
|
||||
.int PEEK_CHAR,LIT,34,EQU,ZBRANCH,(1f - .)
|
||||
.int LIT,1,IN,INCREMENT
|
||||
.int STATE,FETCH,ZBRANCH,(0f - .)
|
||||
.int LIT,LITSTRING,COMMA,CP,FETCH,LIT,0,COMMABYTE
|
||||
.int READSTRING,ROT,STOREBYTE,DROP,ALIGN,EXIT
|
||||
/* ELSE */
|
||||
0: .int READSTRING,EXIT
|
||||
/* ELSE */
|
||||
1: .int PUTBACK,LIT,64,ALLOT,WORD,LIT,-64,ALLOT
|
||||
.int TWODUP,PARSENUMBER,ZBRANCH,(3f - .)
|
||||
1: .int WORD,TWODUP,PARSENUMBER,ZBRANCH,(3f - .)
|
||||
.int NROT,TWODROP
|
||||
.int STATE,FETCH,ZBRANCH,(2f - .)
|
||||
.int LIT,LIT,COMMA,COMMA
|
||||
|
|
@ -1452,7 +1553,7 @@ defword INTERPRET
|
|||
4: .int EXECUTE,EXIT
|
||||
/* ELSE */
|
||||
5: .int DUP,ISBOOTSTRAP,ZBRANCH,(6f - .)
|
||||
litstring "Compiled bootstrap word: "
|
||||
litstring "Tried to compile bootstrap word: "
|
||||
.int TYPE,TNAME,TYPE,EOL,BAILOUT
|
||||
6: .int COMMA,EXIT
|
||||
|
||||
|
|
@ -1466,10 +1567,11 @@ defword CREATE
|
|||
.int LIT,DODATA,COMMA
|
||||
.int LIT,0,COMMA
|
||||
.int CURRENT,FETCH,FETCH,COMMA
|
||||
.int LIT,0,COMMABYTE
|
||||
.int WORD,NIP,DUP,ALLOT,ALIGN
|
||||
.int OVER,TFLAGS,STOREBYTE
|
||||
.int CP,FETCH,OVER,TDFA,STORE
|
||||
.int WORD
|
||||
.int DUP,COMMABYTE
|
||||
.int CP,FETCH,SWAP
|
||||
.int DUP,ALLOT,CMOVE
|
||||
.int ALIGN,CP,FETCH,OVER,TDFA,STORE
|
||||
.int CURRENT,FETCH,STORE,EXIT
|
||||
|
||||
/*
|
||||
|
|
@ -1484,10 +1586,10 @@ defword RBRACKET,"]",F_IMMED
|
|||
.int TRUE,STATE,STORE,EXIT
|
||||
|
||||
defword SLASH,"\\",F_IMMED
|
||||
0: .int KEY,LIT,10,EQU,ZBRANCH,(0b - .),EXIT
|
||||
0: .int NEXT_CHAR,LIT,10,EQU,ZBRANCH,(0b - .),EXIT
|
||||
|
||||
defword PAREN,"(",F_IMMED
|
||||
0: .int KEY,LIT,')',EQU,ZBRANCH,(0b - .),EXIT
|
||||
0: .int NEXT_CHAR,LIT,')',EQU,ZBRANCH,(0b - .),EXIT
|
||||
|
||||
defword COLON,":"
|
||||
/* Make word & fetch address */
|
||||
|
|
@ -1521,6 +1623,12 @@ defword LITERAL,,F_IMMED
|
|||
defword COMPILE_QUOTE,"[']",F_IMMED
|
||||
.int QUOTE,LITERAL,EXIT
|
||||
|
||||
defword CHAR
|
||||
.int WORD,DROP,FETCHBYTE,EXIT
|
||||
|
||||
defword COMPILE_CHAR,"[CHAR]",F_IMMED
|
||||
.int CHAR,LITERAL,EXIT
|
||||
|
||||
defword POSTPONE,,F_IMMED
|
||||
.int WORD,FIND_OR_ABORT,ZGT,ZBRANCH,(0f - .)
|
||||
.int LITERAL
|
||||
|
|
@ -1589,8 +1697,3 @@ startup_defs_end:
|
|||
return_stack:
|
||||
.space RETURN_STACK_SIZE
|
||||
return_stack_top:
|
||||
|
||||
.bss
|
||||
.align 4096
|
||||
buffer:
|
||||
.space BUFFER_SIZE
|
||||
|
|
|
|||
374
startup.4th
374
startup.4th
|
|
@ -116,6 +116,40 @@
|
|||
SYS_GETPID SYSCALL0 SYS_GETTID SYSCALL0 SIGABRT SYS_TGKILL SYSCALL3 DROP
|
||||
AGAIN ;
|
||||
|
||||
\ Display the unsigned number at the top of the stack
|
||||
: U. ( u -- "<digits>" )
|
||||
\ Start with the highest place-value on the left
|
||||
1000000000
|
||||
\ Skip place-values that would be larger than the input
|
||||
BEGIN 2DUP U< OVER 1 U> AND WHILE 10 U/ REPEAT
|
||||
\ Emit the remaining digits down to the units' place
|
||||
BEGIN
|
||||
TUCK U/MOD [CHAR] 0 + EMIT SWAP
|
||||
DUP 1 U<= IF 2DROP EXIT THEN
|
||||
10 U/
|
||||
AGAIN ;
|
||||
|
||||
\ Display the signed number at the top of the stack
|
||||
: . ( n -- "<minus?><digits>" )
|
||||
DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ;
|
||||
|
||||
\ 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 ;
|
||||
|
||||
\ 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 ;
|
||||
|
||||
\ Return the next address in the compilation/data area
|
||||
: HERE ( -- addr ) CP @ ;
|
||||
|
||||
|
|
@ -184,6 +218,15 @@
|
|||
: ELSE ( C: orig1 -- orig2 ) IMMEDIATE
|
||||
POSTPONE AHEAD SWAP POSTPONE THEN ;
|
||||
|
||||
\ Short-circuit logical operators
|
||||
\ Examples:
|
||||
\ <cond1> AND-THEN <cond2> THEN
|
||||
\ <cond1> OR-ELSE <cond2> THEN
|
||||
: AND-THEN ( C: -- orig ) ( Runtime S: flag -- FALSE | <dropped> ) IMMEDIATE
|
||||
POSTPONE DUP POSTPONE IF POSTPONE DROP ;
|
||||
: OR-ELSE ( C: -- orig ) ( Runtime S: flag -- nonzero-flag | <dropped> ) IMMEDIATE
|
||||
POSTPONE ?DUP POSTPONE 0= POSTPONE IF ;
|
||||
|
||||
\ Unbounded loop: BEGIN <body> AGAIN
|
||||
\ BEGIN places the offset of the start of <code> on the stack.
|
||||
\ AGAIN creates a relative branch back to the start of <code>.
|
||||
|
|
@ -247,52 +290,116 @@
|
|||
: ENDCASE ( C: orign ... orig1 n -- ) IMMEDIATE
|
||||
POSTPONE DROP 0 DO POSTPONE THEN LOOP ;
|
||||
|
||||
\ If the input buffer is empty, refill it from stdin
|
||||
\ Return the next character from the input buffer
|
||||
: KEY
|
||||
CURRKEY @
|
||||
DUP BUFFTOP @ >= IF
|
||||
DROP BUFFER 0 OVER BUFFER_SIZE SYS_READ SYSCALL3
|
||||
DUP 0<= IF
|
||||
2DROP
|
||||
BYE
|
||||
SOURCE
|
||||
CREATE INPUT-BUFFER-SIZE ,
|
||||
CREATE INPUT-BUFFER ,
|
||||
|
||||
CREATE CURRENT-SOURCE-ID -1 ,
|
||||
|
||||
: SOURCE ( -- c-addr u ) INPUT-BUFFER @ INPUT-BUFFER-SIZE @ ;
|
||||
: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ;
|
||||
|
||||
: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
|
||||
: RESTORE-INPUT ( xu ... x1 u -- ) OVER >IN ! NDROP ;
|
||||
|
||||
\ The size of this buffer will determine the maximum line length
|
||||
4096 CONSTANT TERMINAL-BUFFER-SIZE
|
||||
CREATE TERMINAL-BUFFER TERMINAL-BUFFER-SIZE ALLOT
|
||||
|
||||
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
|
||||
DROP "Error occurred while reading input\n" TYPE
|
||||
FATAL-ERROR
|
||||
THEN
|
||||
( S: length idx u-read )
|
||||
\ Add the amount of data read to the length; index is unchanged
|
||||
ROT + SWAP
|
||||
THEN
|
||||
THEN
|
||||
OVER + BUFFTOP !
|
||||
THEN
|
||||
DUP 1+ CURRKEY ! C@
|
||||
;
|
||||
\ 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<> ;
|
||||
|
||||
\ Puts the most recently read key back in the input buffer
|
||||
\ CAUTION: Can only safely be used ONCE after each call to KEY!
|
||||
\ This takes advantage of the fact that the key is still in the buffer
|
||||
: PUTBACK CURRKEY @ 1- CURRKEY ! ;
|
||||
: DROP-PREFIX ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) ROT OVER + -ROT - ;
|
||||
|
||||
: SKIPSPACE BEGIN KEY SPACE? INVERT UNTIL PUTBACK ;
|
||||
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ DROP-PREFIX ;
|
||||
|
||||
: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ;
|
||||
|
||||
: PEEK-CHAR ( -- c )
|
||||
PARSE-AREA 0= IF
|
||||
DROP "Unexpected end of input\n" TYPE
|
||||
FATAL-ERROR
|
||||
THEN C@ ;
|
||||
|
||||
: SKIP-CHAR ( -- ) 1 >IN +! ;
|
||||
|
||||
: NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ;
|
||||
|
||||
: SKIPSPACE ( "<spaces?>" -- )
|
||||
BEGIN
|
||||
PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? THEN
|
||||
WHILE
|
||||
SKIP-CHAR
|
||||
REPEAT ;
|
||||
|
||||
\ Comments; ignore all characters until the next EOL or ) character, respectively
|
||||
: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
|
||||
: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = UNTIL ;
|
||||
|
||||
\ Skip whitespace; read and return the next word delimited by whitespace
|
||||
\ The word is stored in contiguous but *unallocated* data space
|
||||
\ The delimiting whitespace character is left in the input buffer
|
||||
\ The delimiting whitespace character is left in the parse area
|
||||
: WORD ( "<spaces>ccc" -- c-addr u )
|
||||
SKIPSPACE
|
||||
HERE
|
||||
PARSE-AREA DROP
|
||||
BEGIN
|
||||
KEY DUP SPACE? 0=
|
||||
PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? THEN 0=
|
||||
WHILE
|
||||
C,
|
||||
SKIP-CHAR
|
||||
REPEAT
|
||||
DROP
|
||||
PUTBACK
|
||||
HERE OVER -
|
||||
OVER CP ! ;
|
||||
PARSE-AREA DROP OVER - ;
|
||||
|
||||
: CREATE ( "<spaces>ccc" -- )
|
||||
ALIGN HERE
|
||||
DODATA , 0 , LATEST ,
|
||||
HERE 0 C, WORD
|
||||
NIP DUP ALLOT ALIGN SWAP C!
|
||||
HERE OVER >DFA !
|
||||
GET-CURRENT !
|
||||
;
|
||||
WORD DUP C, HERE SWAP DUP ALLOT CMOVE
|
||||
ALIGN HERE OVER >DFA !
|
||||
GET-CURRENT ! ;
|
||||
|
||||
\ Called when a word using DOES> is executed (not compiled) to set
|
||||
\ the runtime behavior of the most recently defined word
|
||||
|
|
@ -328,6 +435,8 @@
|
|||
\ name execution: ( -- value )
|
||||
: VALUE CREATE , DOES> @ ;
|
||||
|
||||
: (TRACE) >NAME TYPE SPACE .DS EOL ;
|
||||
|
||||
\ Define a threaded FORTH word
|
||||
\ 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
|
||||
|
|
@ -335,7 +444,9 @@
|
|||
CREATE LATEST
|
||||
DUP >FLAGS DUP C@ F_HIDDEN OR SWAP C!
|
||||
DOCOL SWAP >CFA !
|
||||
POSTPONE ] ;
|
||||
POSTPONE ]
|
||||
\ ( uncomment for tracing ) LATEST POSTPONE LITERAL POSTPONE (TRACE)
|
||||
;
|
||||
|
||||
\ Like : but the definition has no name
|
||||
\ The zero-length name still included in the word list so LATEST can refer to it
|
||||
|
|
@ -452,23 +563,6 @@
|
|||
THEN
|
||||
AGAIN ;
|
||||
|
||||
\ Display the unsigned number at the top of the stack
|
||||
: U. ( u -- "<digits>" )
|
||||
\ Start with the highest place-value on the left
|
||||
1000000000
|
||||
\ Skip place-values that would be larger than the input
|
||||
BEGIN 2DUP U< OVER 1 U> AND WHILE 10 U/ REPEAT
|
||||
\ Emit the remaining digits down to the units' place
|
||||
BEGIN
|
||||
TUCK U/MOD [CHAR] 0 + EMIT SWAP
|
||||
DUP 1 U<= IF 2DROP EXIT THEN
|
||||
10 U/
|
||||
AGAIN ;
|
||||
|
||||
\ Display the signed number at the top of the stack
|
||||
: . ( n -- "<minus?><digits>" )
|
||||
DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ;
|
||||
|
||||
\ Field accessors for the search order linked list
|
||||
: ORDER>LINK ( a-addr1 -- a-addr2 ) ;
|
||||
: ORDER>WID ( a-addr1 -- a-addr2 ) CELL+ ;
|
||||
|
|
@ -605,8 +699,7 @@ DEFER ABORT ( -- <noreturn> )
|
|||
|
||||
\ Same as FIND except that unknown words are reported and result in a call to ABORT
|
||||
: FIND-OR-ABORT ( c-addr u -- xt 1 | xt -1 )
|
||||
FIND ?DUP IF EXIT THEN
|
||||
"UNKNOWN WORD: " TYPE TYPE EOL ABORT ;
|
||||
FIND ?DUP 0= IF "UNKNOWN WORD: " TYPE TYPE EOL ABORT THEN ;
|
||||
|
||||
\ Read a word from the input (during runtime) and return its execution token
|
||||
\ Aborts if the word is not found in the current (runtime) search order list
|
||||
|
|
@ -658,6 +751,25 @@ HIDE ORDER-FREELIST
|
|||
HIDE ORDER>WID
|
||||
HIDE ORDER>LINK
|
||||
|
||||
: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
|
||||
NEXT-CHAR DUP [CHAR] \ = IF
|
||||
DROP NEXT-CHAR CASE
|
||||
[CHAR] 0 OF 0 ENDOF
|
||||
[CHAR] a OF 7 ENDOF
|
||||
[CHAR] b OF 8 ENDOF
|
||||
[CHAR] t OF 9 ENDOF
|
||||
[CHAR] n OF 10 ENDOF
|
||||
[CHAR] v OF 11 ENDOF
|
||||
[CHAR] f OF 12 ENDOF
|
||||
[CHAR] r OF 13 ENDOF
|
||||
[CHAR] " OF [CHAR] " ENDOF
|
||||
[CHAR] ' OF [CHAR] ' ENDOF
|
||||
[CHAR] \ OF [CHAR] \ ENDOF
|
||||
"Unknown escape sequence: \\" TYPE DUP EMIT EOL
|
||||
FATAL-ERROR
|
||||
ENDCASE
|
||||
THEN ;
|
||||
|
||||
\ Read a literal character string up to the next double-quote character
|
||||
\ Unlike WORD the string is stored in contiguous *allocated* data space
|
||||
\ The delimiting double-quote character is removed from the input buffer
|
||||
|
|
@ -665,17 +777,12 @@ HIDE ORDER>LINK
|
|||
: READSTRING ( "ccc<doublequote>" -- c-addr u )
|
||||
HERE
|
||||
BEGIN
|
||||
KEY
|
||||
DUP [CHAR] \ = IF
|
||||
DROP KEY TRUE
|
||||
ELSE
|
||||
DUP [CHAR] " <>
|
||||
THEN
|
||||
PEEK-CHAR [CHAR] " <>
|
||||
WHILE
|
||||
C,
|
||||
ESCAPED-CHAR C,
|
||||
REPEAT
|
||||
DROP HERE OVER -
|
||||
;
|
||||
SKIP-CHAR
|
||||
HERE OVER - ;
|
||||
|
||||
: PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE )
|
||||
DUP 0= IF FALSE EXIT THEN
|
||||
|
|
@ -700,38 +807,68 @@ HIDE ORDER>LINK
|
|||
\ 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 )
|
||||
SKIPSPACE
|
||||
KEY
|
||||
[CHAR] " = IF
|
||||
STATE @ IF
|
||||
POSTPONE LITSTRING
|
||||
HERE 0 C,
|
||||
READSTRING NIP SWAP C! ALIGN
|
||||
ELSE
|
||||
READSTRING
|
||||
THEN
|
||||
ELSE
|
||||
PUTBACK 64 ALLOT WORD -64 ALLOT
|
||||
PARSENUMBER IF
|
||||
BEGIN
|
||||
SKIPSPACE
|
||||
PARSE-EMPTY? 0=
|
||||
WHILE
|
||||
PEEK-CHAR [CHAR] " = IF
|
||||
SKIP-CHAR
|
||||
STATE @ IF
|
||||
POSTPONE LITERAL
|
||||
POSTPONE LITSTRING
|
||||
HERE 0 C,
|
||||
READSTRING NIP SWAP C! ALIGN
|
||||
ELSE
|
||||
READSTRING
|
||||
THEN
|
||||
ELSE
|
||||
FIND-OR-ABORT
|
||||
\ -1 => immediate word; execute regardless of STATE
|
||||
\ 1 => read STATE; compile if true, execute if false
|
||||
0< IF EXECUTE EXIT THEN
|
||||
STATE @ IF COMPILE, EXIT THEN
|
||||
EXECUTE
|
||||
WORD
|
||||
PARSENUMBER IF
|
||||
STATE @ IF
|
||||
POSTPONE LITERAL
|
||||
THEN
|
||||
ELSE
|
||||
FIND-OR-ABORT
|
||||
\ -1 => immediate word; execute regardless of STATE
|
||||
\ 1 => read STATE; compile if true, execute if false
|
||||
0< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN
|
||||
THEN
|
||||
THEN
|
||||
THEN ;
|
||||
REPEAT ;
|
||||
|
||||
\ Comments; ignore all characters until the next EOL or ) character, respectively
|
||||
: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN KEY LF = UNTIL ;
|
||||
: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN KEY [CHAR] ) = UNTIL ;
|
||||
\ Empty the return stack, make stdin the input source, and enter interpretation state
|
||||
: QUIT ( -- <noreturn> )
|
||||
R0 RSP!
|
||||
0 CURRENT-SOURCE-ID !
|
||||
FALSE STATE !
|
||||
BEGIN
|
||||
REFILL 0= IF
|
||||
EOL BYE
|
||||
THEN
|
||||
INTERPRET
|
||||
STATE @ 0= IF
|
||||
"OK> " TYPE
|
||||
THEN
|
||||
AGAIN ;
|
||||
|
||||
\ Empty the return stack and enter interpretation state
|
||||
: QUIT ( -- <noreturn> ) R0 RSP! FALSE STATE ! BEGIN INTERPRET AGAIN ;
|
||||
: EVALUATE ( i*x c-addr u -- j*x )
|
||||
SAVE-INPUT N>R
|
||||
SOURCE 2>R
|
||||
SOURCE-ID >R
|
||||
INPUT-BUFFER-SIZE !
|
||||
INPUT-BUFFER !
|
||||
0 >IN !
|
||||
-1 CURRENT-SOURCE-ID !
|
||||
INTERPRET
|
||||
R> CURRENT-SOURCE-ID !
|
||||
2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER !
|
||||
NR> RESTORE-INPUT ;
|
||||
|
||||
HIDE CURRENT-SOURCE-ID
|
||||
HIDE INPUT-BUFFER
|
||||
HIDE INPUT-BUFFER-SIZE
|
||||
HIDE TERMINAL-BUFFER
|
||||
HIDE TIB-LEFTOVER
|
||||
HIDE TIB-LEFTOVER-SIZE
|
||||
|
||||
\ Redefine ABORT as a non-deferred word; update deferred references to point here
|
||||
\ Empty the data stack and then perform the function of QUIT without any message
|
||||
|
|
@ -744,7 +881,7 @@ HIDE ABORT
|
|||
\ Switch to the interpreter defined in this startup file
|
||||
FORTH-WORDLIST 1 SET-ORDER
|
||||
DEFINITIONS
|
||||
QUIT
|
||||
{ R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE
|
||||
|
||||
\ *****************************************************************************
|
||||
\ Bootstrapping is complete
|
||||
|
|
@ -754,48 +891,48 @@ QUIT
|
|||
\ Return the number of words on the data stack
|
||||
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
|
||||
|
||||
\ 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 ;
|
||||
|
||||
\ 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 ;
|
||||
|
||||
\ Attempt to locate a visible word whose execution token matches the given address
|
||||
\ If found return the word name and TRUE; otherwise just return FALSE
|
||||
: LOOKUP ( addr -- c-addr u TRUE | FALSE )
|
||||
\ 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
|
||||
: WORD? ( addr -- flag )
|
||||
>R
|
||||
GET-ORDER
|
||||
1+ GET-CURRENT SWAP
|
||||
BEGIN
|
||||
?DUP
|
||||
WHILE
|
||||
1- SWAP R@ FALSE ROT
|
||||
( S: widn ... wid1 n addr FALSE wid ) ( R: addr )
|
||||
{ ( addr FALSE xt -- addr FALSE FALSE | c-addr u TRUE TRUE )
|
||||
NIP OVER = IF
|
||||
>NAME TRUE
|
||||
ELSE
|
||||
FALSE
|
||||
THEN DUP } WITH-VISIBLE
|
||||
?DUP IF RDROP EXIT THEN
|
||||
DROP
|
||||
\ Inner function: ( addr FALSE xt -- addr FALSE FALSE | addr TRUE TRUE )
|
||||
{ NIP OVER = DUP } WITH-WORDLIST
|
||||
NIP IF RDROP NDROP TRUE EXIT THEN
|
||||
REPEAT
|
||||
RDROP FALSE ;
|
||||
|
||||
\ Display the top of the stack as a word name if possible, or a number otherwise
|
||||
\ Words with zero-length names (e.g. from :NONAME) are displayed as numbers
|
||||
: .W ( addr -- "<name>" | "<digits>" )
|
||||
DUP LOOKUP IF TYPE DROP ELSE . THEN ;
|
||||
DUP WORD? IF
|
||||
\ Some kind of word; is the name zero-length (:NONAME)?
|
||||
DUP >NAME DUP IF
|
||||
\ Is the name hidden?
|
||||
2 PICK HIDDEN? IF
|
||||
"×" TYPE
|
||||
ELSE
|
||||
\ Does FIND with the same name fail to return the same word?
|
||||
2DUP FIND AND-THEN 3 PICK = ELSE NIP NIP THEN 0= IF
|
||||
"¤" TYPE
|
||||
THEN
|
||||
THEN
|
||||
TYPE
|
||||
DROP
|
||||
ELSE
|
||||
2DROP "∷" TYPE U.
|
||||
THEN
|
||||
ELSE
|
||||
\ Not a word in the current search order or compilation word list
|
||||
.
|
||||
THEN ;
|
||||
|
||||
\ Display the first `u` words in the body of the given execution token with .W
|
||||
: UNTHREAD ( xt u -- )
|
||||
|
|
@ -809,6 +946,7 @@ QUIT
|
|||
DROP
|
||||
;
|
||||
|
||||
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ;
|
||||
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\nOK> " TYPE ;
|
||||
|
||||
BANNER
|
||||
QUIT
|
||||
|
|
|
|||
Loading…
Reference in New Issue