vaguely working interpretation

3 files changed, 130 insertions, 27 deletions

diff --git a/readme.md b/readme.md
index 6416c28..a9fa679 100644
--- a/readme.md
+++ b/readme.md
@@ -1,6 +1,6 @@
-# sanctuary forth (working title)
+# sanctuary (working title)
 
-sanctuary forth is a 64-bit subroutine threaded forth system
+sanctuary is a 64-bit subroutine threaded forth system
 for amd64 linux systems.
 
 ## stack effect notation
@@ -21,12 +21,23 @@ the following is a list of words available in this forth.
 ### `#tib   ( -- a )`
 variable containing the amount of characters in the input buffer.
 
+### `(header)   ( a u -- xt )`
+create a dictionary header for a word named the provided string.
+this word does not set the code field.
+this word returns an incompleted xt and does not update latest.
+
 ### `[   ( -- ) IMMEDIATE`
 set the system to interpret mode.
 
 ### `]   ( -- ) IMMEDIATE`
 set the system to compiling mode.
 
+### `:   ( "name" -- )`
+start compilation of the word 'name'.
+
+### `;   ( -- ) IMMEDIATE`
+end compilation of the currently compiling word.
+
 ### `>body   ( xt -- a )`
 yield the code field of xt.
 
@@ -83,9 +94,9 @@ the most recently created word.
 ### `literal   ( n -- ) IMMEDIATE COMPILE-ONLY`
 compile a push of the literal value n into the currently compiling word.
 
-### `number   ( a u -- n 0 | -1 )`
+### `number   ( a u -- n -1 | 0 )`
 convert given string into a number along with a flag.
-if parsing a number fails then -1 (false) is returned
+if parsing a number fails then 0 (false) is returned
 and no number is provided.
 
 ### `parse   ( "name<c>" c -- a u )`
@@ -99,6 +110,9 @@ and return as a string.
 tabs (ascii 0x09), newlines (ascii 0x10), and spaces (ascii 0x20)
 are considered whitespace.
 
+### `smudge   ( -- )`
+toggles the smudge bit on the xt in latest.
+
 ### `state   ( -- a )`
 a variable containing a boolean value.
 if 0 (false), the system is in interpreting mode,
diff --git a/sanctuary.fs b/sanctuary.fs
index 55cb17e..43dc7bb 100644
--- a/sanctuary.fs
+++ b/sanctuary.fs
@@ -1 +1,3 @@
-.s
+: .s2  1 2 3 [ 7 ] literal .s ;
+4 5 6 .s2
+bye
diff --git a/sanctuary.s b/sanctuary.s
index eda1466..a2ba5dd 100644
--- a/sanctuary.s
+++ b/sanctuary.s
@@ -44,8 +44,8 @@
 %assign immediate_mask	0x2
 %assign comp_only_mask	0x4
 
-%assign true 0x0
-%assign false (~0x0)
+%assign false 0x0
+%assign true (~0x0)
 
 %assign INTERPRET 0x0
 %assign COMPILING (~0x0)
@@ -55,6 +55,8 @@
 %assign __NR_brk	12
 %assign __NR_exit	60
 
+%assign init_brk	0x9c400
+
 section .bss
 resq 4091
 wstk: resq 1
@@ -68,9 +70,15 @@ _start:
 	pspop r11
 	mov qword [dp], r11
 	mov qword [dp0], r11
-	mov r11, 0x9c400
+	mov r11, init_brk
 	pspush r11
 	call grow
+	; TODO grow should call executable automatically
+	mov r11, qword [dp0]
+	pspush r11
+	mov r11, init_brk
+	pspush r11
+	call executable
 	call interpret
 	call bye
 
@@ -279,6 +287,7 @@ defcode "find", find, 0
 ; r11: word found flag
 ; r12: state
 ; TODO respect comp-only flag (do this once error handling is impld)
+; TODO it doesnt work right
 defcode "interpret", interpret, 0
 .loop:
 	call parse_name
@@ -286,47 +295,53 @@ defcode "interpret", interpret, 0
 	je .eof
 	call find
 	mov r12, qword [state]
-	cmp r12, INTERPRET
-	jne .compl
-
+	cmp r12, COMPILING
+	je .compl
+ 
 	pspop r11
-	test r11, r11 ; set SF if negative (word found)
-	js .intrpnum
+	cmp r11, false
+	je .intrpnum
 
 .callw: ; label here for immed jump
 	call to_body
-	pspop r14
-	call r14
+	pspop r13
+	call r13
 	jmp .loop
 
 .intrpnum:
 	call number
 	pspop r11
-	test r11, r11
-	js .notfound
+	cmp r11, false
+	je .notfound
 	jmp .loop
 
 .compl:
+	; call dots
 	pspop r11
-	test r11, r11
-	js .complnum
+	cmp r11, false
+	je .complnum
 
 	; dup immediate? if [imm] else normal then
+	; i think this is broken (; not working)
 	call dup
+	; call dots
 	call immediate_q
+	; call dots
 	pspop r13
-	test r13, r13
-	jns .callw
+	cmp r13, true
+	je .callw
 
 	call to_body
 	call compile_comma
 	jmp .loop
 
 .complnum:
+	; call dots
 	call number
+	; call dots
 	pspop r11
-	test r11, r11
-	js .notfound
+	cmp r11, false
+	je .notfound
 	call literal
 	jmp .loop
 
@@ -345,6 +360,9 @@ defcode "immediate?", immediate_q, 0
 	mov r12b, byte [r11]
 	xor r13, r13
 	test r12b, immediate_mask
+	setnz r13b
+	neg r13
+	pspush r13
 	ret
 
 defcode ">body", to_body, 0
@@ -362,7 +380,7 @@ defcode "literal", literal, immediate_mask|comp_only_mask
 	; 49 bb VAL
 	; 4d 89 1f
 	pspop r11
-	mov r12, qword [here]
+	mov r12, qword [dp]
 
 	mov dword [r12], 0xf87f8d4d
 	add r12, 4
@@ -375,12 +393,12 @@ defcode "literal", literal, immediate_mask|comp_only_mask
 	mov byte [r12], 0x1f
 	inc r12
 
-	mov qword [here], r12
+	mov qword [dp], r12
 	ret
 
 defcode "compile,", compile_comma, 0
 	pspop r11
-	mov r12, [here]
+	mov r12, [dp]
 
 	; compile mov r11, [cfa]
 	mov word [r12], 0xbb49
@@ -394,7 +412,7 @@ defcode "compile,", compile_comma, 0
 	mov byte [r12], 0xd3
 	inc r12
 
-	mov qword [here], r12
+	mov qword [dp], r12
 	ret
 
 defcode "[", lbrac, immediate_mask
@@ -405,6 +423,63 @@ defcode "]", rbrac, immediate_mask
 	mov qword [state], COMPILING
 	ret
 
+defcode "(header)", brac_header, 0
+	pspop r9
+	pspop r10
+	mov r11, qword [latest]
+	mov r12, qword [dp]
+	push r12
+
+	mov qword [r12], r11
+	add r12, 8
+	mov byte [r12], 0
+	inc r12
+	mov byte [r12], r9b
+	inc r12
+
+	mov rcx, r9
+	mov rsi, r10
+	mov rdi, r12
+	rep movsb
+	add r12, r9
+
+	mov qword [dp], r12
+	pop r12
+	pspush r12
+	ret
+
+defcode ":", colon, 0
+	call parse_name
+	; todo check zero
+	call brac_header
+	pspop r11
+	mov qword [latest], r11
+	call smudge
+	mov qword [state], COMPILING
+	ret
+
+defcode ";", semicolon, immediate_mask
+	mov r12, [latest]
+	add r12, 8
+	mov r13b, [r12]
+	and r13b, ~smudge_mask ; does this syntax work? equiv SMUDGEMASK NOT
+	mov byte [r12], r13b
+
+	mov r11, qword [dp]
+	mov byte [r11], 0xc3 ; ret
+	inc r11
+	mov qword [dp], r11
+	mov qword [state], INTERPRET
+	ret
+
+defcode "smudge", smudge, 0
+	mov r12, [latest]
+	add r12, 8
+	mov r13b, [r12]
+	xor r13b, smudge_mask
+	mov byte [r12], r13b
+	ret
+
 ; number {{{
 defcode "number", number, 0 ; ( c-addr u -- ?n flag )
 	pspop r11 ; u
@@ -481,6 +556,7 @@ defcode "dup", dup, 0
 	pspush r11
 	ret
 
+; TEMPORARY WONKY DEBUGGING FUNCTIONS {{{
 ; .s {{{
 defcode ".s", dots, 0
 	push r11
@@ -520,6 +596,17 @@ defcode ".s", dots, 0
 .dmsg: db "DONEDONEYIPPEEEE"
 ; }}}
 
+defcode "HEREDUMP", heredump, 0
+	mov rdx, [dp]
+	mov r11, [dp0]
+	sub rdx, r11
+	mov rsi, [dp0]
+	mov rdi, 1
+	mov rax, __NR_write
+	syscall
+	ret
+; }}}
+
 defvar "state", state, 0, INTERPRET
 defvar "base", base, 0, 10
 defvar "dp", dp, 0, 0