Add VALUE 2VALUE TO FIND words.

Author: Molorius

README.md

@@ -797,9 +797,11 @@ Missing words may be implemented in the future.
 * `OF`
 * `PICK`
 * `ROLL`
+* `TO`
 * `TRUE`
 * `TUCK`
 * `U>`
+* `VALUE`
 * `WITHIN`
 * `[COMPILE]`
 * `\`
@@ -826,6 +828,7 @@ all can be in the future.
 
 # Standard Double extension words
 
+* `2VALUE`
 * `DU<`
 
 # Optimizations

pkg/forth/builtin/01_compile.f

@@ -20,7 +20,7 @@
 
 \ ' (tick) parses the next name and places the execution token of that name
 \ onto the stack.
-BL WORD ' --CREATE-FORTH ] BL WORD FIND-WORD EXIT [
+BL WORD ' --CREATE-FORTH ] BL WORD -1 FIND-WORD DROP EXIT [
 
 \ POSTPONE parses the next name and compiles the compilation semantics of that word
 \ onto the latest word. Immediate.

pkg/forth/builtin/02_core.f

@@ -210,6 +210,42 @@
     POSTPONE ;
 ;
 
+: VALUE
+    1 ALLOCATE DROP
+    SWAP OVER !
+    :
+    POSTPONE LITERAL
+    POSTPONE @
+    POSTPONE ;
+;
+
+: TO
+    ' \ find the next word
+    >BODY DUP \ get the first address
+    DUP LAST-ADDRESS SWAP - 1+ \ find the length of this allocated space
+    1 = IF \ if it's a VALUE
+        STATE @ IF
+            POSTPONE LITERAL POSTPONE !
+        ELSE
+            !
+        THEN
+    ELSE \ if it's a 2VALUE
+        STATE @ IF
+            DUP 1+
+            POSTPONE LITERAL POSTPONE !
+            POSTPONE LITERAL POSTPONE !
+        ELSE
+            SWAP OVER 1+
+            !
+            !
+        THEN
+    THEN
+; IMMEDIATE
+
+: FIND ( caddr -- caddr 0 | xt 1 | xt -1 )
+    FALSE FIND-WORD
+;
+
 : ACTION-OF
     STATE @ IF
         POSTPONE ['] POSTPONE DEFER@

pkg/forth/builtin/03_double.f

@@ -79,3 +79,18 @@
 
 : 2VARIABLE 2 BUFFER: ;
 : GLOBAL-2VARIABLE 2 GLOBAL-BUFFER: ;
+
+: 2VALUE ( x y "<spaces>name" -- )
+    2 ALLOCATE DROP ( x y addr )
+    SWAP OVER 1+ ( x addr y addr+1 )
+    ! ( x addr )
+    SWAP OVER ( addr x addr )
+    ! ( addr )
+    DUP 1+ SWAP ( addr+1 addr )
+    :
+    POSTPONE LITERAL
+    POSTPONE @
+    POSTPONE LITERAL
+    POSTPONE @
+    POSTPONE ;
+;

pkg/forth/primitive.go

@@ -74,7 +74,7 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 				if !ok {
 					return EntryError(entry, "requires an address cell")
 				}
-				name, err := countedCellsToString(cellAddr.Entry.Word.(*WordForth).Cells)
+				name, err := addrToString(cellAddr)
 				if err != nil {
 					return JoinEntryError(err, entry, "could not parse name")
 				}
@@ -169,7 +169,7 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 				if !ok {
 					return EntryError(entry, "requires an address cell")
 				}
-				name, err := countedCellsToString(cellAddr.Entry.Word.(*WordForth).Cells)
+				name, err := addrToString(cellAddr)
 				if err != nil {
 					return JoinEntryError(err, entry, "could not parse name")
 				}
@@ -539,8 +539,13 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 			},
 		},
 		{
-			name: "FIND-WORD",
+			name: "FIND-WORD", // ( caddr errorIfMissing -- caddr 0 | xt 1 | xt -1 )
 			goFunc: func(vm *VirtualMachine, entry *DictionaryEntry) error {
+				num, err := vm.Stack.PopNumber()
+				if err != nil {
+					return PopError(err, entry)
+				}
+				errorIfMissing := num != 0
 				cell, err := vm.Stack.Pop()
 				if err != nil {
 					return PopError(err, entry)
@@ -549,19 +554,39 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 				if !ok {
 					return EntryError(entry, "requires an address cell")
 				}
-				name, err := countedCellsToString(cellAddr.Entry.Word.(*WordForth).Cells)
+				name, err := addrToString(cellAddr)
 				if err != nil {
 					return JoinEntryError(err, entry, "could not convert input to string")
 				}
 				found, err := vm.Dictionary.FindName(string(name))
-				if err != nil {
-					return JoinEntryError(err, entry, "could not find name: %s", name)
+				missing := err != nil
+				if missing {
+					if errorIfMissing {
+						return JoinEntryError(err, entry, "could not find name: %s", name)
+					}
+					err = vm.Stack.Push(cellAddr)
+					if err != nil {
+						return PushError(err, entry)
+					}
+					err = vm.Stack.Push(CellNumber{0})
+					if err != nil {
+						return PushError(err, entry)
+					}
+					return nil
 				}
 				newCell := CellAddress{found, 0, false}
 				err = vm.Stack.Push(newCell)
 				if err != nil {
 					return PushError(err, entry)
 				}
+				ret := -1
+				if found.Flag.Immediate {
+					ret = 1
+				}
+				err = vm.Stack.Push(CellNumber{uint16(ret)})
+				if err != nil {
+					return PushError(err, entry)
+				}
 				return nil
 			},
 		},
@@ -688,7 +713,7 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 				if !ok {
 					return EntryError(entry, "requires a name")
 				}
-				name, err := countedCellsToString(cellAddr.Entry.Word.(*WordForth).Cells)
+				name, err := addrToString(cellAddr)
 				if err != nil {
 					return JoinEntryError(err, entry, "could not parse name")
 				}
@@ -2618,7 +2643,7 @@ func parseWord(vm *VirtualMachine, entry *DictionaryEntry) (string, error) {
 	if !ok {
 		return "", EntryError(entry, "name argument needs to be an address to a string")
 	}
-	name, err := countedCellsToString(cellAddr.Entry.Word.(*WordForth).Cells)
+	name, err := addrToString(cellAddr)
 	if err != nil {
 		return "", JoinEntryError(err, entry, "could not parse name")
 	}
@@ -2638,7 +2663,7 @@ func parseAssembly(vm *VirtualMachine, entry *DictionaryEntry) ([]string, error)
 		}
 		switch c := cell.(type) {
 		case CellAddress:
-			substr, err := countedCellsToString(c.Entry.Word.(*WordForth).Cells)
+			substr, err := addrToString(c)
 			if err != nil {
 				return nil, JoinEntryError(err, entry, "could not convert input to string")
 			}

pkg/forth/suite_test.go

@@ -700,7 +700,17 @@ UNSIGNED: 0 FFFF
 				T{ SEEBUF -> 20 20 20 }T
 			`,
 		},
-		// FIND is not implemented
+		{
+			name: "FIND",
+			setup: `
+				HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
+				HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
+				HERE 3 ALLOT CONSTANT GT3STRING \ empty string size 3
+				T{ GT1STRING FIND -> ' GT1 -1    }T
+				T{ GT2STRING FIND -> ' GT2 1     }T
+				T{ GT3STRING FIND -> GT3STRING 0 }T
+			`,
+		},
 		// FM/MOD is not implemented
 		// HERE see , ALLOT C,
 		// HOLD is not implemented
@@ -1537,7 +1547,32 @@ func TestCoreExtensionSuite(t *testing.T) {
 			`,
 		},
 		// UNUSED not implemented
-		// VALUE not implemented
+		{
+			name: "VALUE",
+			setup: `
+				T{  111 VALUE v1 -> }T
+				T{ -999 VALUE v2 -> }T
+				T{ : vd1 v1 ;    -> }T
+				T{ : vd2 TO v2 ; -> }T
+
+				T{ 123 VALUE v3 ->     }T
+				T{ v3           -> 123 }T
+				T{ 456 TO v3    ->     }T
+				T{ v3           -> 456 }T
+			`,
+			code: `
+				T{ v1 ->  111 }T
+				T{ v2 -> -999 }T
+				T{ 222 TO v1 -> }T
+				T{ v1 -> 222 }T
+				T{ vd1 -> 222 }T
+
+				T{ v2 -> -999 }T
+				T{ -333 vd2 -> }T
+				T{ v2 -> -333 }T
+				T{ v1 ->  222 }T
+			`,
+		},
 		// WITHIN does not have test cases
 		{
 			name: "[COMPILE]",
@@ -1854,7 +1889,24 @@ func TestDoubleSuite(t *testing.T) {
 func TestDoubleExtensionSuite(t *testing.T) {
 	tests := []suiteTest{
 		// 2ROT not implemented
-		// 2VALUE not implemented
+		{
+			name: "2VALUE",
+			setup: `
+				T{ 1 2 2VALUE t2val -> }T
+				: sett2val t2val 2SWAP TO t2val ;
+
+				T{ 1 2 2VALUE t2val2 -> }T
+				T{ t2val2 -> 1 2 }T
+				T{ 3 4 to t2val2 -> }T
+				T{ t2val2 -> 3 4 }T
+			`,
+			code: `
+				T{ t2val -> 1 2 }T
+				T{ 3 4 TO t2val -> }T
+				T{ t2val -> 3 4 }T
+				T{ 5 6 sett2val t2val -> 3 4 5 6 }T
+			`,
+		},
 		{
 			name: "DU<",
 			code: `

pkg/forth/utils.go

@@ -51,11 +51,25 @@ func cellsToBytes(cells []Cell) ([]byte, error) {
 	return out, nil
 }
 
-func countedCellsToString(cells []Cell) (string, error) {
-	bytes, err := cellsToBytes(cells)
+func addrToString(addr CellAddress) (string, error) {
+	word, ok := addr.Entry.Word.(*WordForth)
+	if !ok {
+		return "", fmt.Errorf("can only read string of forth word found %T", addr.Entry.Word)
+	}
+	cells := word.Cells
+	offset := addr.Offset
+	upper := addr.UpperByte
+	return countedCellsToString(cells, offset, upper)
+}
+
+func countedCellsToString(cells []Cell, offset int, upper bool) (string, error) {
+	bytes, err := cellsToBytes(cells[offset:])
 	if err != nil {
 		return "", err
 	}
+	if upper {
+		bytes = bytes[1:]
+	}
 	length := bytes[0]
 	return bytesToString(bytes[1:], int(length))
 }