Add >BODY CHAR CREATE DOES> and tests.

Author: Molorius

README.md

@@ -477,6 +477,7 @@ error if it cannot be cannot be cross compiled.
 * `<`
 * `=`
 * `>`
+* `>BODY`
 * `>R`
 * `?DUP`
 * `@`
@@ -496,15 +497,20 @@ error if it cannot be cannot be cross compiled.
 * `C@`
 * `CELL+`
 * `CELLS`
+* `CHAR`
 * `CHAR+`
 * `CHARS`
 * `CONSTANT`
   * Can only run on host.
 * `COUNT`
 * `CR`
+* `CREATE`
+  * Can only run on host.
 * `DECIMAL`
 * `DEPTH`
 * `DO`
+* `DOES>`
+  * Can only run on host.
 * `DROP`
 * `DUP`
 * `ELSE`

pkg/forth/builtin/01_compile.f

@@ -28,30 +28,30 @@
 
 \ CREATE parses the next name and creates a Forth definition
 \ for that name.
-BL WORD CREATE ( -- ) --CREATE-FORTH ] BL WORD --CREATE-FORTH EXIT [
+BL WORD CREATEWORD ( -- ) --CREATE-FORTH ] BL WORD --CREATE-FORTH EXIT [
 
 \ SEE parses the next name and prints the definition of that word.
 \ An error is thrown if there is not a word with that name in the dictionary.
-CREATE SEE ] BL WORD --SEE EXIT [ \ not core but really nice for debugging
+CREATEWORD SEE ] BL WORD --SEE EXIT [ \ not core but really nice for debugging
 
 \ TRUE places the 'true' value onto the stack.
-CREATE TRUE ( -- true ) ] -1 EXIT [
+CREATEWORD TRUE ( -- true ) ] -1 EXIT [
 
 \ FALSE places the 'false' value onto the stack.
-CREATE FALSE ( -- false ) ] 0 EXIT [
+CREATEWORD FALSE ( -- false ) ] 0 EXIT [
 
 \ : parses the next name, creates a dictionary entry for it, hides that word,
 \ and puts the VM into compile state. 
 \ Used to start compilation.
-CREATE : ( -- ) ]
-    CREATE \ create the new dictionary entry
+CREATEWORD : ( -- ) ]
+    CREATEWORD \ create the new dictionary entry
     TRUE LAST SET-HIDDEN \ hide it
     ] \ and put in compile mode
 EXIT [
 
 \ ; appends EXIT to the most recent definition, unhides it, and puts the VM into interpret state.
 \ Used to end compilation. Immediate.
-CREATE ; ( -- ) ]
+CREATEWORD ; ( -- ) ]
     POSTPONE EXIT \ compile EXIT into new word
     FALSE LAST SET-HIDDEN \ unhide the new word
     POSTPONE [ \ put back in interpret mode

pkg/forth/builtin/02_core.f

@@ -91,6 +91,10 @@
     SWAP 1 AND \ isolate the lowest bit
     + \ then put back the pit
 ;
+: CHAR
+    BL WORD
+    CHAR+ C@
+;
 
 : U> SWAP U< ; \ greaterthan is just lessthan with operands swapped
 : > 
@@ -444,3 +448,25 @@
     LOOP
     2DROP
 ;
+
+: CREATE
+    ALIGN \ align the data space pointer
+    HERE \ get the data space pointer
+    : \ parse the next input, create a word with that name
+    POSTPONE LITERAL \ create a literal of the previous data space pointer
+    POSTPONE EXIT \ put an extra exit, can be overwritten
+    POSTPONE ; \ end the definition
+;
+
+: DOES>
+    POSTPONE EXIT \ put a dummy value here for now
+    LAST \ get the definition that called DOES>
+    LAST-ADDRESS \ get the last address of that definition
+    POSTPONE LAST \ later get the most recent definition
+    POSTPONE 1+ \ later go 1 past the end
+    POSTPONE ! \ later store the value
+    POSTPONE ; \ end the definition that called DOES>
+    :NONAME \ start a new unnamed definition
+    LITERALIZE \ literalize the noname address
+    SWAP ! \ store the literal noname address inside the dummy value
+; IMMEDIATE

pkg/forth/primitive.go

@@ -743,6 +743,49 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 				return nil
 			},
 		},
+		{
+			name: "LAST-ADDRESS",
+			goFunc: func(vm *VirtualMachine, entry *DictionaryEntry) error {
+				// get address
+				cell, err := vm.Stack.Pop()
+				if err != nil {
+					return PopError(err, entry)
+				}
+				cellAddress, ok := cell.(CellAddress)
+				if !ok {
+					return EntryError(entry, "can only get length of an address, got %s type %T", cellAddress, cellAddress)
+				}
+				w, ok := cellAddress.Entry.Word.(*WordForth)
+				if !ok {
+					return EntryError(entry, "can only get length of forth data words found %s type %T", w, w)
+				}
+				// get length
+				length := len(w.Cells)
+				// update the address cell with the last value
+				cellAddress.Offset = length - 1
+				cellAddress.UpperByte = false
+				err = vm.Stack.Push(cellAddress)
+				if err != nil {
+					return PushError(err, entry)
+				}
+				return nil
+			},
+		},
+		{
+			// convert a cell into a literal of that cell
+			name: "LITERALIZE",
+			goFunc: func(vm *VirtualMachine, entry *DictionaryEntry) error {
+				cell, err := vm.Stack.Pop()
+				if err != nil {
+					return PopError(err, entry)
+				}
+				err = vm.Stack.Push(CellLiteral{cell})
+				if err != nil {
+					return PushError(err, entry)
+				}
+				return nil
+			},
+		},
 		{
 			name: "@",
 			goFunc: func(vm *VirtualMachine, entry *DictionaryEntry) error {

pkg/forth/suite_test.go

@@ -134,12 +134,12 @@ func TestSuite(t *testing.T) {
 				T{ 127 CHARS BUFFER: TBUF2 -> }T \ Buffer is aligned
 				T{ TBUF1 ALIGNED -> TBUF1 }T \ Buffers do not overlap
 				\ T{ TBUF2 TBUF1 - ABS 127 CHARS < -> <FALSE> }T \ Buffer can be written to
-				\ 1 CHARS CONSTANT /CHAR
-				\ : TFULL? ( c-addr n char -- flag )
-				\    TRUE 2SWAP CHARS OVER + SWAP ?DO
-				\      OVER I C@ = AND
-				\    /CHAR +LOOP NIP
-				\ ;
+				1 CHARS CONSTANT /CHAR
+				: TFULL? ( c-addr n char -- flag )
+				   TRUE 2SWAP CHARS OVER + SWAP ?DO
+				     OVER I C@ = AND
+				   /CHAR +LOOP NIP
+				;
 				\ T{ TBUF1 127 CHAR * FILL   ->        }T
 				\ T{ TBUF1 127 CHAR * TFULL? -> <TRUE> }T
 				\ T{ TBUF1 127 0 FILL   ->        }T
@@ -267,7 +267,13 @@ func TestSuite(t *testing.T) {
 				T{ c1 CHAR+ C@ -> 0x12 }T
 			`,
 		},
-		// CHAR
+		{
+			name: "CHAR",
+			setup: `
+				T{ CHAR X     -> 58 }T
+				T{ CHAR HELLO -> 48 }T
+			`,
+		},
 		// CHAR+
 		// CHARS
 		// COMPILE,
@@ -412,7 +418,26 @@ func TestSuite(t *testing.T) {
 			`,
 		},
 		// DO does not have any tests
-		// DOES>
+		{
+			name: "DOES>",
+			setup: `
+				T{ : DOES1 DOES> @ 1 + ; -> }T
+				T{ : DOES2 DOES> @ 2 + ; -> }T
+				T{ CREATE CR1 -> }T
+				T{ CR1   -> HERE }T
+				T{ 1 ,   ->   }T
+				T{ CR1 @ -> 1 }T
+				T{ DOES1 ->   }T
+				T{ CR1   -> 2 }T
+				T{ DOES2 ->   }T
+				T{ CR1   -> 3 }T
+				T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T
+				T{ WEIRD: W1 -> }T
+				T{ ' W1 >BODY -> HERE }T
+				T{ W1 -> HERE 1 + }T
+				T{ W1 -> HERE 2 + }T
+			`,
+		},
 		{
 			name: "DROP",
 			code: `
@@ -531,14 +556,12 @@ func TestSuite(t *testing.T) {
 				T{ VARIABLE iw3 IMMEDIATE 234 iw3 ! iw3 @ -> 234 }T
 				T{ : iw4 iw3 [ @ ] LITERAL ; iw4 -> 234 }T
 				T{ :NONAME [ 345 ] iw3 [ ! ] ; DROP iw3 @ -> 345 }T
-				\ The rest of these tests fail because CREATE does not
-				\ put the newly created definition on the data space.
-				\ T{ CREATE iw5 456 , IMMEDIATE -> }T
-				\ T{ :NONAME iw5 [ @ iw3 ! ] ; DROP iw3 @ -> 456 }T
-				\ T{ : iw6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T
-				\ T{ 111 iw6 iw7 iw7 -> 112 }T
-				\ T{ : iw8 iw7 LITERAL 1+ ; iw8 -> 113 }T
-				\ T{ : iw9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T
+				T{ CREATE iw5 456 , IMMEDIATE -> }T
+				T{ :NONAME iw5 [ @ iw3 ! ] ; DROP iw3 @ -> 456 }T
+				T{ : iw6 CREATE , IMMEDIATE DOES> @ 1+ ; -> }T
+				T{ 111 iw6 iw7 iw7 -> 112 }T
+				T{ : iw8 iw7 LITERAL 1+ ; iw8 -> 113 }T
+				T{ : iw9 CREATE , DOES> @ 2 + IMMEDIATE ; -> }T
 				\ : find-iw BL WORD FIND NIP ;
 				\ T{ 222 iw9 iw10 find-iw iw10 -> -1 }T    \ iw10 is not immediate
 				\ T{ iw10 find-iw iw10 -> 224 1 }T          \ iw10 becomes immediate
@@ -1360,7 +1383,13 @@ func TestSuite(t *testing.T) {
 				T{  1 ?DUP ->  1  1 }T
 			`,
 		},
-		// >BODY does not have a test case we can replicate
+		{
+			name: ">BODY",
+			setup: `
+				T{  CREATE CR0 ->      }T
+				T{ ' CR0 >BODY -> HERE }T
+			`,
+		},
 		// >IN
 		// >NUMBER
 		{