nybble
/
jumpforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

implement the Search-Order word set

This commit is contained in:
Jesse D. McDonald 2020-10-05 01:32:31 -05:00
parent 60333e365c
commit 3790a647fd
2 changed files with 240 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
jumpforth.S
View File

@ -37,14 +37,14 @@
.globl _start
_start:
cld
mov %esp,param_S0
mov %esp,data_S0
mov $return_stack_top,%ebp
xor %ebx,%ebx
movl $__NR_brk,%eax
int $0x80
movl %eax,param_C0
movl %eax,var_CP
movl %eax,var_BRK
movl %eax,data_C0
movl %eax,data_CP
movl %eax,data_BRK
mov $cold_start,%esi
NEXT
@ -64,11 +64,21 @@ DOCOL:
/* (By default the DFA field holds the address of the body of the definition) */
.text
.align 4
.globl DOSELF
DOSELF:
.globl DODATA
DODATA:
pushl 4(%eax)
NEXT
/* The default behavior for words defined with VALUE (or defparam) */
/* Load the word at the address in the DFA field and place it on the stack */
.text
.align 4
.globl DOLOAD
DOLOAD:
movl 4(%eax),%eax
pushl (%eax)
NEXT
/* The entry point for threaded FORTH words defined with CREATE/DOES> */
/* Push the return address (%esi) on the return stack */
/* Load the address of the DOES> code body from the DFA field at %eax+4 */
@ -95,7 +105,7 @@ DODOES:
NEXT
.macro defname label:req,codeword:req,dataword:req,name="",flags=0
.section .rodata
.section .data
.align 4
.globl \label
\label :
@ -113,11 +123,11 @@ DODOES:
.endm
.macro defword label:req,name="",flags=0
defname \label,DOCOL,data_\label,"\name",\flags
defname \label,DOCOL,thread_\label,"\name",\flags
.section .rodata
.align 4
.globl data_\label
data_\label :
.globl thread_\label
thread_\label :
.endm
.macro defcode label:req,name="",dataword=0,flags=0
@ -127,31 +137,29 @@ defname \label,code_\label,\dataword,"\name",\flags
code_\label :
.endm
.macro defvar label:req,initial=0,name="",flags=0
defcode \label,"\name",0,\flags
push $var_\label
NEXT
.macro defdata label:req,name="",flags=0
defname \label,DODATA,data_\label,"\name",\flags
.data
.align 4
var_\label :
data_\label :
.endm
.macro defvar label:req,initial=0,name="",flags=0
defdata \label,"\name",\flags
.int \initial
.endm
.macro defconst label:req,value,name="",flags=0
defcode \label,"\name",0,\flags
push $\value
NEXT
defname \label,DODATA,\value,"\name",\flags
.endm
/* Parameters are stored like variables but produce a value, not an address. */
/* Use this for data which is read-only after initialization. */
.macro defparam label:req,initial=0,name="",flags=0
defcode \label,"\name",0,\flags
pushl param_\label
NEXT
defname \label,DOLOAD,data_\label,"\name",\flags
.data
.align 4
param_\label :
data_\label :
.int \initial
.endm
@ -163,7 +171,8 @@ defconst BUFFER,buffer
defconst __BUFFER_SIZE,BUFFER_SIZE,"BUFFER_SIZE"
defconst __DOCOL,DOCOL,"DOCOL"
defconst __DOSELF,DOSELF,"DOSELF"
defconst __DODATA,DODATA,"DODATA"
defconst __DOLOAD,DOLOAD,"DOLOAD"
defconst __DODOES,DODOES,"DODOES"
defconst FALSE,0
@ -563,7 +572,19 @@ defvar BUFFTOP,startup_defs_end
defvar CP /* "compilation pointer", next free byte in the heap */
defvar BRK /* the (current) end of the heap */
defvar LATEST,last_word
/* The initial word list containing all the standard FORTH words */
defvar FORTH_WORDLIST,last_word,"FORTH-WORDLIST"
/* The current compilation word list, initially FORTH-WORDLIST */
defvar CURRENT,data_FORTH_WORDLIST
.section .data
.align 4
initial_order:
.int 0,data_FORTH_WORDLIST
/* Head of the linked list representing the current search order */
defvar CURRENT_ORDER,initial_order,"CURRENT-ORDER"
/* ( a -- ) */
defcode DROP
@ -658,6 +679,12 @@ defcode TWOSWAP,"2SWAP"
push %ebx
NEXT
/* ( xn ... x1 n -- ) */
defcode NDROP
pop %eax
lea (%esp,%eax,4),%esp
NEXT
/* ( 0 -- 0 ) */
/* ( a -- a a ) */
defcode QDUP,"?DUP"
@ -1111,35 +1138,59 @@ defword ISIMMEDIATE,"IMMEDIATE?"
defword ISHIDDEN,"HIDDEN?"
.int LIT,12,ADD,FETCHBYTE,__F_HIDDEN,AND,LIT,0,NEQU,EXIT
defword FIND
.int LATEST,FETCH /* c-addr u entry */
/* Convert search order entry address to address of word list identifier field */
defword ORDER_TWID,"ORDER>WID"
.int CELL,ADD,EXIT
/* Convert search order entry address to address of link field */
defword ORDER_TLINK,"ORDER>LINK"
.int EXIT
/* ( c-addr u wid -- 0 | xt 1 | xt -1 ) */
/* 0 = not found; 1 = non-immediate; -1 = immediate */
defword SEARCH_WORDLIST,"SEARCH-WORDLIST"
.int FETCH /* c-addr u entry */
0: .int DUP,ZBRANCH,(4f - .) /* c-addr u entry */
.int DUP,ISHIDDEN,ZBRANCH,(2f - .) /* c-addr u entry */
1: .int TLINK,FETCH,BRANCH,(0b - .) /* c-addr u link */
2: .int DUP,TOR,NROT,FROMR,TNAME,TWOOVER /* entry c-addr u n-addr n-len c-addr u */
.int STREQU,ZBRANCH,(3f - .) /* entry c-addr u */
.int TWODROP,EXIT /* entry */
.int TWODROP,DUP,ISIMMEDIATE,LIT,1,OR,EXIT /* entry 1 | entry -1 */
3: .int ROT,BRANCH,(1b - .) /* c-addr u entry */
4: .int NROT,TWODROP,EXIT /* entry (= 0) */
4: .int NIP,NIP,EXIT /* entry (= 0) */
defword FINDERR
.int TWODUP,FIND,QDUP,ZBRANCH,(0f - .),NROT,TWODROP,EXIT
/* ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) */
defword FIND
.int TWOTOR,CURRENT_ORDER
0: .int FETCH,QDUP,ZBRANCH,(1f - .)
.int DUP,ORDER_TLINK,SWAP,ORDER_TWID,FETCH
.int TWORFETCH,ROT,SEARCH_WORDLIST,QDUP,ZBRANCH,(0b - .)
.int TWORDROP,ROT,DROP,EXIT
1: .int TWOFROMR,LIT,0,EXIT
/* ( c-addr u -- xt 1 | xt -1 ) */
defword FIND_OR_ABORT,"FIND-OR-ABORT"
.int FIND,QDUP,ZBRANCH,(0f - .),EXIT
0: litstring "UNKNOWN WORD: "
.int TYPE,TYPE,LIT,'\n',EMIT,ABORT
defword QUOTE,"'"
.int WORD,FINDERR,EXIT
.int WORD,FIND_OR_ABORT,DROP,EXIT
defword CREATE
.int ALIGN,HERE,LIT,DOSELF,COMMA,LIT,0,COMMA,LATEST,FETCH,COMMA,LIT,0,COMMABYTE
.int ALIGN,HERE
.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 HERE,OVER,TDFA,STORE
.int LATEST,STORE,EXIT
.int CURRENT,FETCH,STORE,EXIT
defword COLON,":"
.int CREATE
.int LATEST,FETCH
.int CURRENT,FETCH,FETCH
.int DUP,TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,OR,SWAP,STOREBYTE
.int LIT,DOCOL,OVER,TCFA,STORE
.int HERE,SWAP,TDFA,STORE
@ -1149,9 +1200,9 @@ defword NONAME,":NONAME"
.int ALIGN,HERE
.int LIT,DOCOL,COMMA
.int HERE,LIT,12,ADD,COMMA
.int LATEST,FETCH,COMMA
.int CURRENT,FETCH,FETCH,COMMA
.int __F_HIDDEN,COMMABYTE,ALIGN
.int DUP,LATEST,STORE
.int DUP,CURRENT,FETCH,STORE
.int TRUE,STATE,STORE
.int EXIT
@ -1160,12 +1211,12 @@ defword _UNHIDE_,"(UNHIDE)",F_HIDDEN
.int TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,INVERT,AND,SWAP,STOREBYTE,EXIT
defword SEMI,";",F_IMMED
.int LIT,EXIT,COMMA,LATEST,FETCH,_UNHIDE_
.int LIT,EXIT,COMMA,CURRENT,FETCH,FETCH,_UNHIDE_
.int FALSE,STATE,STORE,ALIGN,EXIT
/* ( dfa -- ) Set CFA of latest word to DODOES and set DFA field to address on stack */
defword _DOES_,"(DOES)",F_HIDDEN
.int LATEST,FETCH,LIT,DODOES,OVER,TCFA,STORE,TDFA,STORE,EXIT
.int CURRENT,FETCH,FETCH,LIT,DODOES,OVER,TCFA,STORE,TDFA,STORE,EXIT
/* Append "<addr> (DOES) EXIT" to the current definition */
/* where <addr> is the next address after the "EXIT" as a literal number */
@ -1220,7 +1271,7 @@ defword INTERPRET
.int LIT,LIT,COMMA,COMMA
2: .int EXIT
/* ELSE */
3: .int FINDERR
3: .int FIND_OR_ABORT,DROP
.int STATE,FETCH,ZBRANCH,(4f - .)
/* ( OR ) */
.int DUP,ISIMMEDIATE,ZBRANCH,(5f - .)
@ -1238,7 +1289,7 @@ defword QUIT
.int R0,RSPSTORE
0: .int INTERPRET,BRANCH,(0b - .)
/* This is the initial value of the LATEST variable */
/* This is the initial value of the FORTH_WORDLIST variable */
.set last_word,QUIT
.section .rodata

173
startup.4th
View File

@ -14,9 +14,20 @@
\ Emit a blank (space) character
: SPACE BL EMIT ;
\ Separate division and modulus operators
: / /MOD NIP ;
: MOD /MOD DROP ;
\ Get and set the current compilation word list
: GET-CURRENT CURRENT @ ;
: SET-CURRENT CURRENT ! ;
\ Get the execution token of the most recent word in the compilation word list
: LATEST GET-CURRENT @ ;
\ Set the latest defined word as immediate
\ Note that IMMEDIATE is itself an immediate word
: IMMEDIATE LATEST @ >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE
: IMMEDIATE LATEST >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE
\ Switch from compiling to interpreting, or vice-versa
: [ FALSE STATE ! ; IMMEDIATE
@ -28,7 +39,7 @@
: COMPILE, , ;
\ Append the execution semantics of the current definition to the current definition.
: RECURSE LATEST @ COMPILE, ; IMMEDIATE
: RECURSE LATEST COMPILE, ; IMMEDIATE
\ Append the LIT xt and the topmost word on the stack to the current definition.
\ If POSTPONE were already defined then this could simply be written as:
@ -41,9 +52,9 @@
\ Read a word and append its compilation semantics to the current definition.
: POSTPONE ( "<spaces>name" -- ) IMMEDIATE
WORD FINDERR
WORD FIND-OR-ABORT DROP
\ Would be: DUP IMMEDIATE? IF COMPILE, EXIT THEN
DUP IMMEDIATE? 0BRANCH [ 3 CELL * , ] COMPILE, EXIT
DUP IMMEDIATE? 0BRANCH [ HERE 0 , ] COMPILE, EXIT [ HERE OVER - SWAP ! ]
[ ' LITERAL COMPILE, ' COMPILE, ] LITERAL COMPILE,
;
@ -75,9 +86,9 @@
\ Inline :NONAME-style function literals. "{ <code> }" has the runtime effect
\ of placing the execution token for an anonymous function with the runtime
\ effect of <code> on the top of the data stack. A branch is emitted to skip
\ over the memory used for the nested definition. The original value of LATEST
\ is restored at the end of the definition. If RECURSE is used in <code> it
\ will create a recursive call to the anonymous inner function.
\ over the memory used for the nested definition, which is removed from the
\ current word list upon completion. If RECURSE is used in <code> it will
\ create a recursive call to the anonymous inner function.
\
\ Example:
\ OK> : TIMES 0 DO DUP EXECUTE LOOP DROP ;
@ -91,7 +102,7 @@
\ Interpreter effect: ( C: -- latest state )
\ Enters compilation mode if not already compiling
: {
LATEST @
LATEST
STATE @
DUP IF
POSTPONE AHEAD
@ -107,11 +118,11 @@
POSTPONE ; SWAP IF
-ROT
POSTPONE THEN
LATEST !
GET-CURRENT !
POSTPONE LITERAL
POSTPONE ]
ELSE
SWAP LATEST !
SWAP GET-CURRENT !
THEN
; IMMEDIATE
@ -134,7 +145,7 @@
: UNLOOP POSTPONE 2RDROP ; IMMEDIATE
: DO POSTPONE 2>R POSTPONE BEGIN ; IMMEDIATE
: (+LOOP) ( step limit index -- flag limit index' )
ROT + 2DUP <= -ROT ;
ROT + 2DUP <> -ROT ;
: +LOOP
POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R POSTPONE UNTIL POSTPONE 2RDROP
; IMMEDIATE
@ -163,7 +174,9 @@
\ Define a named constant.
\ Execution: ( value "<spaces>name" -- )
\ name Execution: ( -- value )
: CONSTANT : POSTPONE LITERAL POSTPONE ; ;
\ Alternate definition:
\ : CONSTANT : POSTPONE LITERAL POSTPONE ; ;
: CONSTANT CREATE LATEST DODATA OVER >CFA ! >DFA ! ;
\ Define a single-cell named variable which returns its data address when executed.
\ The initial value is formally undefined. This implementation sets it to zero.
@ -183,10 +196,6 @@
( x "<spaces>name" -- )
: TO ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; IMMEDIATE
\ Separate division and modulus operators
: / /MOD NIP ;
: MOD /MOD DROP ;
\ Display the signed number at the top of the stack
: . ( n -- "<minussign?><digits>" )
DUP -2147483648 = IF
@ -211,6 +220,123 @@
THEN
;
\ When the search order is changed previously allocated entries that are not
\ currently needed will be retained on this linked list for later reuse.
VARIABLE ORDER-FREELIST
0 ORDER-FREELIST !
\ Return the current search order
: GET-ORDER ( -- widn ... wid1 n )
0 CURRENT-ORDER @
\ Traverse the linked list, placing identifiers on the return stack and counting
BEGIN ?DUP WHILE DUP ORDER>WID @ >R ORDER>LINK @ SWAP 1+ SWAP REPEAT
( S: n ) ( R: wid1 ... widn )
\ Shift the search order list from the return stack back to the data stack
DUP BEGIN ?DUP WHILE 1- R> -ROT REPEAT
( S: widn ... wid1 n )
;
\ Set the current search order
: SET-ORDER ( widn ... wid1 n | -n -- )
DUP 0 < IF DROP FORTH-WORDLIST 1 THEN
\ Move all the previous search order entries to the free list
CURRENT-ORDER @
BEGIN
( S: widn ... wid1 n entry )
?DUP
WHILE
DUP ORDER>LINK @ SWAP
ORDER-FREELIST @ OVER ORDER>LINK !
ORDER-FREELIST !
REPEAT
\ Build the new search order linked list
CURRENT-ORDER SWAP
BEGIN
( S: widn ... wid1 tail n )
?DUP
WHILE
-ROT
( S: widn ... wid2 n wid1 tail )
ORDER-FREELIST @ ?DUP IF
\ Remove an entry from the free list
DUP ORDER>LINK @ ORDER-FREELIST !
ELSE
\ Allocate a new entry from the data area
ALIGN HERE 2 CELL * ALLOT
THEN
\ Update the tail pointer with the address of this entry
DUP ROT !
\ Store the word list identifier
TUCK ORDER>WID !
\ Leave the address of the link field under n-1 for the next iteration
ORDER>LINK SWAP 1-
REPEAT
\ Terminate the linked list
0 SWAP !
;
\ Create a new wordlist
\ In this implementation a word list is just a pointer to the most recent word
: WORDLIST ( -- wid )
ALIGN HERE 0 ,
;
\ Abstract away the internals of the search order implementation
HIDE CURRENT
HIDE CURRENT-ORDER
HIDE ORDER-FREELIST
HIDE ORDER>WID
HIDE ORDER>LINK
\ Make the first list in the search order the current compilation word list
: DEFINITIONS ( -- ) GET-ORDER SWAP SET-CURRENT 1- NDROP ;
\ Run a function for each word in the given wordlist
\ xt Execution: ( x*i word-xt -- stop-flag x*j )
: WITH-WORDLIST ( x*i wid xt -- x*j )
>R @
BEGIN
?DUP
WHILE
>R 2R@ SWAP EXECUTE IF
RDROP 0
ELSE
R> >LINK @
THEN
REPEAT
RDROP
;
\ Like WITH-WORDLIST but only runs the function for visible (non-hidden) words
: WITH-VISIBLE ( x*i wid xt -- x*j )
SWAP { DUP HIDDEN? IF DROP FALSE ELSE SWAP DUP >R EXECUTE R> SWAP THEN }
WITH-WORDLIST DROP ;
\ Display the names of each visible word in the given word list
: SHOW-WORDLIST ( wid -- ) { >NAME TYPE SPACE 0 } WITH-VISIBLE EOL ;
\ Return the number of visible words in the given word list
: COUNT-WORDLIST ( wid -- n ) 0 SWAP { DROP 1+ 0 } WITH-VISIBLE ;
\ Alternative definition of SEARCH-WORDLIST using WITH-VISIBLE (for demonstration)
: SEARCH-WORDLIST' ( c-addr u wid -- c-addr u 0 | xt 1 | xt -1 )
0 SWAP {
>R DROP 2DUP R@ >NAME =S IF
2DROP R> DUP IMMEDIATE? 1 OR TRUE
ELSE
RDROP 0 FALSE
THEN
} WITH-VISIBLE ;
\ Search-Order extension words
: ALSO GET-ORDER >R DUP R> 1+ SET-ORDER ;
: FORTH GET-ORDER NIP FORTH-WORDLIST SWAP SET-ORDER ;
: ONLY -1 SET-ORDER ;
: ORDER GET-ORDER
"ORDER:" TYPE BEGIN ?DUP WHILE 1- SWAP SPACE . REPEAT EOL
"CURRENT: " TYPE GET-CURRENT . EOL ;
: PREVIOUS ( -- ) GET-ORDER NIP 1- SET-ORDER ;
\ Display the content of the data stack
: .DS
SP@ S0
@ -238,7 +364,7 @@
\ Attempt to locate a 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 )
LATEST @
LATEST
BEGIN
?DUP IF
\ entry address is not zero
@ -263,13 +389,12 @@
: UNTHREAD ( xt u -- )
SWAP >DFA @ SWAP
BEGIN
?DUP IF
SWAP DUP @ .W BL EMIT
CELL + SWAP 1-
ELSE
DROP EXIT
THEN
AGAIN
?DUP
WHILE
SWAP DUP @ .W BL EMIT
CELL + SWAP 1-
REPEAT
DROP
;
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ;