From 3790a647fdf3c225f559dd1f0aa965553069386a Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Mon, 5 Oct 2020 01:32:31 -0500 Subject: [PATCH] implement the Search-Order word set --- jumpforth.S | 131 +++++++++++++++++++++++++++------------ startup.4th | 173 ++++++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 240 insertions(+), 64 deletions(-) diff --git a/jumpforth.S b/jumpforth.S index 4422703..2b5f7d3 100644 --- a/jumpforth.S +++ b/jumpforth.S @@ -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 " (DOES) EXIT" to the current definition */ /* where 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 diff --git a/startup.4th b/startup.4th index 677b7fc..91b093d 100644 --- a/startup.4th +++ b/startup.4th @@ -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 ( "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. "{ }" 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 -\ 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 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 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 "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 "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 -- "" ) 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 ;