more vocab work - injection success

1 files changed, 54 insertions, 16 deletions

diff --git a/sanctuary.fs b/sanctuary.fs
index b5234a0..ad743d2 100644
--- a/sanctuary.fs
+++ b/sanctuary.fs
@@ -9,6 +9,9 @@
 : nip  swap drop ;
 : tuck  swap over ;
 
+\ todo doc
+: 2swap  rot >r rot r> ;
+
 : not  0= ;
 \ todo doc
 : /  /mod nip ;
@@ -43,6 +46,7 @@
 : '  'h >body ;
 : [compile]  ' ( word ) compile, ; immediate compile-only
 : [']  ' ( word ) [compile] literal ; immediate compile-only
+: ['h]  'h ( word ) [compile] literal ; immediate compile-only \ todo doc
 : postpone  'h ( word ) dup immediate? if >body compile,
 	else >body [compile] literal ['] compile, compile, then ; immediate compile-only
 
@@ -67,6 +71,11 @@
 0 constant false
 -1 constant true
 
+\ todo doc
+: >ffa  ( ht -- a )  cell+ ;
+: >nfa  ( ht -- a )  cell+ 1+ ;
+: count ( a -- a' u )  dup c@ swap 1+ swap ;
+
 hex
 : hijacks  ' ( word ) here >r dp ! ( temporarily set dp so we can use , )
 	49 c, bb c, ( xt ) , \ mov r11, xt
@@ -373,8 +382,8 @@ privatise
 		>resolve
 	then ; immediate compile-only
 : i  rp cell+ @ ;
-\ todo leave
-\ todo unloop
+: leave  postpone rdrop postpone r@ postpone >r ; immediate compile-only
+: unloop  postpone rdrop postpone rdrop ; immediate compile-only
 \ }}}
 
 \ todo doc
@@ -382,7 +391,6 @@ privatise
 \ todo doc
 \ based on the forth standard word list reference implementations
 \ words in asm that use latest directly:
-\ find (header) : ; smudge immediate compile-only
 \ the easiest (altho kind of ugly) way i'll probably do this
 \ is to just redefine all of these here
 \ we don't need to redo ; because we already did it above
@@ -430,24 +438,55 @@ defer default-wordlist
 forth-wordlist (vocabulary) forth
 -1 set-order
 
-private{
-}private
 : search-wordlist ( a u wid -- 0 | ht -1 )
 	( wid ) @  begin ( a u ht )
-		dup >r
-		r>
+		>r 2dup r@ ( a u a u ht ; backup str for next loop )
+		>nfa count ( a1 u1 a2 u2 )
+		compare 0= if
+			2drop ( drop backup )
+			r> -1 exit
+		then
+		r> @ ?dup 0=
 	until
-	;
-privatise
+	2drop 0 ;
 
-private{
-: (find) ( a u -- a u 0 | ht -1 )  ;
-: (latest) ( -- a )  ;
-}private
+\ find (header) : ; smudge immediate compile-only
+
+: (find) ( a u -- a u 0 | ht -1 )
+	#order @ 0 ?do
+		2dup i cells context + @ ( a u a u wid )
+		search-wordlist ( a u 0 | a u ht -1 )
+		?dup if
+			>r >r 2drop r> r> ( ht -1 )
+			unloop exit
+		then
+	loop 0 ;
+
+: (smudge)  latest @ >ffa dup c@ [ hex ] 01 [ decimal ] xor swap c! ;
+: (immediate)  latest @ >ffa dup c@ [ hex ] 02 [ decimal ] or swap c! ;
+: (compile-only)  latest @ >ffa dup c@ [ hex ] 04 [ decimal ] or swap c! ;
+
+: ((header))  here >r
+	latest @ ,
+	0 c, dup c,
+	cmove,
+	r> ;
+: (:)  parse-name (header)  latest !  smudge  postpone ] ;
+
+: (latest) ( -- a )  get-current ;
 \ the actual setup is in a compiled word to prevent
 \ the system from shitfucking itself when its only halfway done setting up
-\ :noname  ['] (find) is find ; execute
-privatise
+:noname  [ latest @ ] literal forth-wordlist !
+	forth-wordlist set-current
+	['] (find) is find
+	['] (smudge) is smudge
+	['] (immediate) is immediate
+	['] (compile-only) is compile-only
+	['] ((header)) is (header)
+	['] (:) is :
+	['] (latest) is latest ;
+execute
+\ drop
 \ }}}
 
 \ PROGRAMMING TOOLS {{{
@@ -463,4 +502,3 @@ privatise
 
 :noname  quit ; handler !
 welcome quit bye
-bye