Add HERE , C, ALLOT and ALIGN plus tests.

Author: Molorius

README.md

@@ -449,6 +449,8 @@ error if it cannot be cannot be cross compiled.
 * `+`
 * `+!`
 * `+LOOP`
+* `,`
+  * Can only run on host.
 * `-`
 * `.`
 * `."`
@@ -479,12 +481,18 @@ error if it cannot be cannot be cross compiled.
 * `?DUP`
 * `@`
 * `ABS`
+* `ALIGN`
+  * Can only run on host.
 * `ALIGNED`
+* `ALLOT`
+  * Can only run on host.
 * `AND`
 * `BASE`
 * `BEGIN`
 * `BL`
 * `C!`
+* `C,`
+  * Can only run on host.
 * `C@`
 * `CELL+`
 * `CELLS`
@@ -507,6 +515,7 @@ error if it cannot be cannot be cross compiled.
 * `EXIT`
 * `FIND`
   * Can only run on host.
+* `HERE`
 * `I`
 * `IF`
 * `IMMEDIATE`

pkg/forth/basic_test.go

@@ -54,6 +54,11 @@ func TestPrimitives(t *testing.T) {
 			asm:    wrapMain("3 1 - u."),
 			expect: "2 ",
 		},
+		{
+			name:   "subtract address",
+			asm:    wrapMain("here 1+ char+ here - u. here here 1+ char+ - u. here 1+ here - u."),
+			expect: "32769 32767 1 ",
+		},
 		{
 			name:   "LSHIFT",
 			asm:    wrapMain("1 0 LSHIFT u. 1 1 LSHIFT u. 1 2 LSHIFT u."),

pkg/forth/builtin/02_core.f

@@ -369,3 +369,56 @@
     DROP 0 \ drop the result, return 0
 ;
 
+0 BUFFER: DATASPACE \ create a buffer starting at size 0 to hold the data space
+VARIABLE DATAPOINTER \ create a variable to keep track of the data space pointer
+DATASPACE DATAPOINTER ! \ set the data space pointer
+
+: HERE ( -- addr )
+    DATAPOINTER @ \ return the dataspace pointer plus the size
+;
+
+: DATASIZE
+    DATAPOINTER @ DATASPACE - \ find the size difference
+    0x7FFF AND
+;
+
+: ALLOT ( n -- )
+    DUP DATASIZE + ( n newSize )
+    DUP 0> 0= IF ( n newSize )
+        \ an ambiguous condition exists if we attempt to create a negative data space size
+        \ or exit immediately if 0
+        2DROP
+        EXIT
+    THEN ( n newSize )
+    SWAP DATAPOINTER +! ( newSize ) \ update the data space pointer
+    DATASPACE SWAP ( dataspace newSize )
+    RESIZE ( newaddress 0 ) \ resize the dataspace
+    2DROP \ remove the extra values from the resize
+;
+
+: , ( n -- )
+    HERE ( n here ) \ get the current address pointer
+    1 ALLOT \ increment the dataspace by 1
+    ! \ store the value
+;
+
+: C, ( char -- )
+    HERE DATASPACE - \ find the size difference
+    0< IF \ if the upper bit is set then we don't need to allocate
+
+    ELSE
+        1 ALLOT \ allocate one more space
+        HERE 1- DATAPOINTER ! \ fix the data pointer
+    THEN
+    HERE C! \ store the data
+    HERE CHAR+ DATAPOINTER ! \ update the data pointer
+;
+
+: ALIGN ( )
+    HERE HERE \ get the current address pointer
+    ALIGNED ( here here+n ) \ align the address pointer
+    - ( diff ) \ get the difference between them
+    0x7FFF AND \ shave off the extra bit
+    ALLOT \ change the data space accordingly
+;
+

pkg/forth/primitive.go

@@ -1273,7 +1273,7 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 						}
 						return nil
 					case CellAddress:
-						err = vm.Stack.Push(CellAddress{l.Entry, l.Offset + int(r.Number), false})
+						err = vm.Stack.Push(CellAddress{l.Entry, l.Offset + int(int16(r.Number)), false})
 						if err != nil {
 							return PushError(err, entry)
 						}
@@ -1284,7 +1284,7 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 				case CellAddress:
 					switch l := left.(type) {
 					case CellNumber:
-						err = vm.Stack.Push(CellAddress{r.Entry, int(l.Number) + r.Offset, false})
+						err = vm.Stack.Push(CellAddress{r.Entry, int(int16(l.Number)) + r.Offset, false})
 						if err != nil {
 							return PushError(err, entry)
 						}
@@ -1352,7 +1352,13 @@ func PrimitiveSetup(vm *VirtualMachine) error {
 					switch l := left.(type) {
 					case CellAddress:
 						if l.Entry == r.Entry {
-							err = vm.Stack.Push(CellNumber{uint16(l.Offset) - uint16(r.Offset)})
+							val := int16(l.Offset) - int16(r.Offset)
+							if l.UpperByte && !r.UpperByte {
+								val += -0x8000
+							} else if !l.UpperByte && r.UpperByte {
+								val -= -0x8000
+							}
+							err = vm.Stack.Push(CellNumber{uint16(val)})
 							if err != nil {
 								return PushError(err, entry)
 							}

pkg/forth/suite_test.go

@@ -66,9 +66,37 @@ func TestSuite(t *testing.T) {
 			`,
 		},
 		// AGAIN does not have test cases
-		// ALIGN
+		{
+			name: "ALIGN",
+			setup: `
+				ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
+				CONSTANT A-ADDR CONSTANT UA-ADDR
+				T{ UA-ADDR ALIGNED -> A-ADDR }T
+			`,
+			code: `
+				T{       1 A-ADDR C!         A-ADDR       C@ ->       1 }T
+				T{    1234 A-ADDR !          A-ADDR       @  ->    1234 }T
+				T{ 123 456 A-ADDR 2!         A-ADDR       2@ -> 123 456 }T
+				T{       2 A-ADDR CHAR+ C!   A-ADDR CHAR+ C@ ->       2 }T
+				T{       3 A-ADDR CELL+ C!   A-ADDR CELL+ C@ ->       3 }T
+				T{    1234 A-ADDR CELL+ !    A-ADDR CELL+ @  ->    1234 }T
+				T{ 123 456 A-ADDR CELL+ 2!   A-ADDR CELL+ 2@ -> 123 456 }T
+			`,
+		},
 		// ALIGNED does not have test cases
-		// ALLOT
+		{
+			name: "ALLOT",
+			setup: `
+				HERE 1 ALLOT
+				HERE
+				CONSTANT 2NDA
+				CONSTANT 1STA
+			`,
+			code: `
+				T{ 1STA 2NDA - 0< -> <TRUE> }T    \ HERE MUST GROW WITH ALLOT
+				T{      1STA 1+   ->   2NDA }T    \ ... BY ONE ADDRESS UNIT
+			`,
+		},
 		{
 			name: "AND",
 			code: `
@@ -195,7 +223,25 @@ func TestSuite(t *testing.T) {
 				T{  0 2 cs2 ->  299 }T
 			`,
 		},
-		// C,
+		{
+			name: "C,",
+			setup: `
+				HERE 1 C,
+				HERE 2 C,
+				CONSTANT 2NDC
+				CONSTANT 1STC
+			`,
+			code: `
+				T{    1STC 2NDC - 0< -> <TRUE> }T \ HERE MUST GROW WITH ALLOT
+				T{      1STC CHAR+ ->  2NDC  }T \ ... BY ONE CHAR
+				// T{  1STC 1 CHARS + ->  2NDC  }T \ this test is incorrect
+				T{ 1STC C@ 2NDC C@ ->   1 2  }T
+				T{       3 1STC C! ->        }T
+				T{ 1STC C@ 2NDC C@ ->   3 2  }T
+				T{       4 2NDC C! ->        }T
+				T{ 1STC C@ 2NDC C@ ->   3 4  }T
+			`,
+		},
 		// CELL+ doesn't have regular tests
 		{
 			name: "CELLS",
@@ -281,7 +327,23 @@ func TestSuite(t *testing.T) {
 				T{ nn2 @ EXECUTE -> 9876 }T
 			`,
 		},
-		// ,
+		{
+			name: ",",
+			code: `
+				T{       1ST 2ND - 0< -> <TRUE> }T \ HERE MUST GROW WITH ALLOT
+				T{       1ST CELL+    -> 2ND }T \ ... BY ONE CELL
+				T{   1ST 1 CELLS +    -> 2ND }T
+				T{     1ST @ 2ND @    -> 1 2 }T
+				T{         5 1ST !    ->     }T
+				T{     1ST @ 2ND @    -> 5 2 }T
+				T{         6 2ND !    ->     }T
+				T{     1ST @ 2ND @    -> 5 6 }T
+				T{           1ST 2@   -> 6 5 }T
+				T{       2 1 1ST 2!   ->     }T
+				T{           1ST 2@   -> 2 1 }T
+				T{ 1S 1ST !  1ST @    -> 1S  }T    \ CAN STORE CELL-WIDE VALUE
+			`,
+		},
 		// C"
 		// DECIMAL does not have any tests
 		{
@@ -419,7 +481,7 @@ func TestSuite(t *testing.T) {
 		// FIND
 		// FM/MOD
 		// @ does not have any tests
-		// HERE
+		// HERE does not have any tests
 		// HEX does not have any tests
 		// HOLD
 		// HOLDS
@@ -452,6 +514,8 @@ 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
@@ -1515,15 +1579,15 @@ func TestSuite(t *testing.T) {
 			setup: `
 				T{ 50 CELLS ALLOCATE SWAP addr ! -> 0 }T
 				T{ addr @ ALIGNED -> addr @ }T    \ Test address is aligned
-				// T{ HERE -> datsp @ }T              \ Check data space pointer is unaffected
+				T{ HERE -> datsp @ }T              \ Check data space pointer is unaffected
 				addr @ 50 write-cell-mem
 				addr @ 50 check-cell-mem         \ Check we can access the heap
 				T{ addr @ FREE -> 0 }T
 
 				T{ 99 ALLOCATE SWAP addr ! -> 0 }T
 				T{ addr @ ALIGNED -> addr @ }T    \ Test address is aligned
 				T{ addr @ FREE -> 0 }T
-				// T{ HERE -> datsp @ }T              \ Data space pointer unaffected by FREE
+				T{ HERE -> datsp @ }T              \ Data space pointer unaffected by FREE
 				T{ -1 ALLOCATE SWAP DROP 0= -> <TRUE> }T    \ Memory allocation works with max size
 			`,
 		},
@@ -1544,7 +1608,7 @@ func TestSuite(t *testing.T) {
 				T{ addr @ -1 RESIZE 0= -> addr @ <TRUE> }T
 
 				T{ addr @ FREE -> 0 }T
-				// T{ HERE -> datsp @ }T    \ Data space pointer is unaffected
+				T{ HERE -> datsp @ }T    \ Data space pointer is unaffected
 			`,
 			code: ``,
 		},

pkg/forth/test/suite_test.f

@@ -119,11 +119,14 @@
 \ from the ['] test, used in many
 T{ : GT2 ['] GT1 ; IMMEDIATE -> }T
 
-\ ' EXIT CONSTANT 1ST
-T{ VARIABLE 1ST -> }T \ not the same as the test suite
+HERE 1 ,
+HERE 2 ,
+CONSTANT 2ND
+CONSTANT 1ST
 
 VARIABLE addr
 VARIABLE datsp
+HERE datsp !
 : write-char-mem ( address n -- )
     \ from 0 to n
     0 ?DO