implement the Search-Order word set

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,data_C0
-   movl %eax,var_CP
+   movl %eax,data_CP
-   movl %eax,var_BRK
+   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
+   .globl DODATA
-DOSELF:
+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
+   .globl thread_\label
-data_\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
+.macro defdata label:req,name="",flags=0
-defcode \label,"\name",0,\flags
+defname \label,DODATA,data_\label,"\name",\flags
-   push $var_\label
-   NEXT
    .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
+defname \label,DODATA,\value,"\name",\flags
-   push $\value
-   NEXT
 .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
+defname \label,DOLOAD,data_\label,"\name",\flags
-   pushl param_\label
-   NEXT
    .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
+/* Convert search order entry address to address of word list identifier field */
-   .int LATEST,FETCH                          /* c-addr u entry */
+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
+/* ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) */
-   .int TWODUP,FIND,QDUP,ZBRANCH,(0f - .),NROT,TWODROP,EXIT
+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

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 ( "<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
+\ over the memory used for the nested definition, which is removed from the
-\ is restored at the end of the definition. If RECURSE is used in <code> it
+\ current word list upon completion. If RECURSE is used in <code> it will
-\ will create a recursive call to the anonymous inner function.
+\ 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
+      ?DUP
+   WHILE
       SWAP DUP @ .W BL EMIT
       CELL + SWAP 1-
-      ELSE
+   REPEAT
-         DROP EXIT
+   DROP
-      THEN
-   AGAIN
 ;
 
 : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ;