input stuff, fix parse{,-name} skipping last char of tib

3 files changed, 114 insertions, 19 deletions

diff --git a/readme.md b/readme.md
index df4c021..0e9e694 100644
--- a/readme.md
+++ b/readme.md
@@ -236,6 +236,9 @@ if a word was found,
 its link field address is returned along with the true flag.
 if no word was found or the string is of length zero, abort.
 
+### `?componly?   ( -- )`
+produce a compile-only error.
+
 ### `?notfound?   ( -- )`
 produce a word not found error.
 
@@ -443,9 +446,6 @@ and skip to `then` if the corresponding `if` was true.
 ### `emit   ( c -- )`
 print the single character c to output.
 
-### `etype   ( a u -- )`
-write u characters at a to error output.
-
 ### `executable   ( a u -- )`
 marks the u bytes starting at address a as executable.
 this is used primarily to mark the program break,
@@ -779,6 +779,9 @@ create a variable word, which yields an address that can be written and read.
 ### `w/o   ( -- 1 )`
 a constant, meaning 'write only', used for file I/O.
 
+### `warn   ( a u -- )`
+write u characters at a to error output.
+
 ### `while   ( ? -- ) IMMEDIAT COMPILE-ONLYE`
 if given flag is true, continue the current begin-while-repeat loop,
 otherwise branch to after.
diff --git a/sanctuary.fs b/sanctuary.fs
index 1acb5ee..9e4d56e 100644
--- a/sanctuary.fs
+++ b/sanctuary.fs
@@ -180,10 +180,12 @@ false value nonaming
 : sys-close  3 syscall1 ;
 
 : type  swap stdout sys-write drop ;
-: etype  swap stderr sys-write drop ;
+: warn  swap stderr sys-write drop ;
 : emit  sp 1 type drop ;
+: eemit  sp 1 warn drop ; \ todo doc
 
 : cr  10 emit ;
+: ecr  10 eemit ; \ todo doc
 
 0 constant r/o
 1 constant w/o
@@ -204,15 +206,18 @@ init-source value source-id
 \ syntax highlighting cannot handle this. oops,,
 : ."  postpone s" postpone type ; immediate compile-only \ "
 
-: e."  postpone s" postpone etype ; immediate compile-only \ "
-: (abort") ( ? a u -- )   rot 0<> if etype abort else 2drop then ;
+: e."  postpone s" postpone warn ; immediate compile-only \ "
+: (abort") ( ? a u -- )   rot 0<> if warn abort else 2drop then ;
 : abort"  postpone s" postpone (abort") ; immediate compile-only
 
+\ ERROR MESSAGES {{{
 \ stk under/overflow ones need to clear the stack first
 \ feels wrong but i think its correct
-:noname  e." word not found" cr abort ; is ?notfound?
-:noname  sp-reset e." stack overflow" cr abort ; is ?overflow?
-:noname  sp-reset e." stack underflow" cr abort ; is ?underflow?
+:noname  e." word not found" ecr abort ; is ?notfound?
+:noname  e." compile-only word used in interpret mode" ecr abort ; is ?componly?
+:noname  sp-reset e." stack overflow" ecr abort ; is ?overflow?
+:noname  sp-reset e." stack underflow" ecr abort ; is ?underflow?
+\ }}}
 
 \ if you need more than 16 layers of included files: go away™
 \ todo doc
@@ -222,8 +227,74 @@ init-source value source-id
 2048 constant /line-buffer
 
 \ this bit is so large that i may increase the default brk
-create buffers  /buffer #buffers * allot
-create line-buffers  /line-buffer #buffers * allot
+create buffers		/buffer #buffers * allot
+create buffers-used	#buffers cells allot
+create buffers->in	#buffers cells allot
+create buffers-fd	#buffers cells allot
+
+create line-buffers		/line-buffer #buffers * allot
+create line-buffers-used	#buffers cells allot
+create line-buffers->in		#buffers cells allot
+
+: cbuffer  include-depth /buffer * buffers + ;
+: cbuffer-used  include-depth cells buffers-used + ;
+: cbuffer->in  include-depth cells buffers->in + ;
+: cbuffer-fd  include-depth cells buffers-fd + ;
+
+: cline  include-depth /line-buffer * line-buffers + ;
+: cline-used  include-depth cells line-buffers-used + ;
+: cline->in  include-depth cells line-buffers->in + ;
+
+: refill-buffer ( -- u | 0 )  cbuffer /buffer cbuffer-fd @ read-file
+	0<> if drop 0 then
+	0 cbuffer->in !  dup cbuffer-used ! ;
+: cbuffer-empty?  cbuffer->in @ cbuffer-used @ >= ;
+: bufkey ( -- c | -1 )
+	cbuffer-empty? if
+		refill-buffer 0= if -1 exit then
+	then
+	cbuffer cbuffer->in @ + c@
+	cbuffer->in @ 1+ cbuffer->in ! ;
+
+private{
+0 value #read
+0 value #read-limit
+0 value destination-base
+: finish-accept ( -- u )  #read ;
+}private
+\ uses memory for readability, maybe too slow?
+\ need to test to see.
+: accept ( a u -- u )  0 to #read  to #read-limit  to destination-base
+	begin
+		#read #read-limit <
+	while
+		bufkey dup 0>=  over 10 <>  and if
+			destination-base #read + c!
+			1 +to #read
+		else
+			drop finish-accept exit
+		then
+	repeat
+	finish-accept ( only reached when buffer limit reached ) ;
+privatise
+
+\ note: these are completely different from ans forth's words of the same name
+\ todo check source-id
+: save-input  #tib @ cline-used !  >in @ cline->in ! ;
+: restore-input  cline-used @ #tib !  cline->in @ >in !  cline tib ! ;
+
+: dump-line  cline cline-used @ type ;
+
+: refill ( -- ? )  source-id 0< if false exit then
+	0 >in !  cline tib !
+	cline /line-buffer accept
+	dup cline-used !
+	dup #tib !
+	0<> if true else false then .s ;
+
+: quit  0 to source-id  postpone [
+	begin refill while interpret ( ." ok" cr ) repeat ;
+quit
 
 \ OLD VERSION I GAVE UP ON BECAUSE IT'S TOO COMPLICATED AND SUCKS SHIT {{{
 \ 8192 constant /buffer
diff --git a/sanctuary.s b/sanctuary.s
index 80b0cbc..b1544a9 100644
--- a/sanctuary.s
+++ b/sanctuary.s
@@ -190,7 +190,7 @@ defcode "parse-name", parse_name, 0
 	je .wsloop
 
 	cmp rsi, r10
-	jge .empty
+	jg .empty
 	mov r11, 1
 	dec rsi ; bring down by one to point to the start
 	push rsi ; will become `a`
@@ -204,7 +204,7 @@ defcode "parse-name", parse_name, 0
 	je .wordloop_e
 
 	cmp rsi, r10
-	jge .wordloop_e
+	jg .wordloop_e
 	inc r11
 	lodsb
 	jmp .wordloop
@@ -216,6 +216,8 @@ defcode "parse-name", parse_name, 0
 	pop rsi
 	pspush rsi
 	pspush r11
+	; call twodup
+	; call intrpdump
 	ret
 
 .empty:
@@ -237,7 +239,7 @@ defcode "parse", parse, 0
 
 .wsloop:
 	cmp rsi, r10
-	jge .empty
+	jg .empty
 	lodsb
 	cmp al, bl
 	je .wsloop
@@ -245,7 +247,7 @@ defcode "parse", parse, 0
 	je .wsloop
 
 	cmp rsi, r10
-	jge .empty
+	jg .empty
 	mov r11, 1
 	dec rsi ; bring down by one to point to the start
 	push rsi ; will become `a`
@@ -257,7 +259,7 @@ defcode "parse", parse, 0
 	je .wordloop_e
 
 	cmp rsi, r10
-	jge .wordloop_e
+	jg .wordloop_e
 	inc r11
 	lodsb
 	jmp .wordloop
@@ -323,11 +325,26 @@ defdefer "find", find, 0
 	pspush r13
 	ret
 
+; ; tmp dbg
+; defcode "INTRPDUMP", intrpdump, 0
+; 	pspop rdx ; u
+; 	pspop rsi ; a
+; 	mov rdi, 1
+; 	mov rax, __NR_write
+; 	syscall
+;
+; 	mov rdx, 1
+; 	mov rsi, .spc
+; 	mov rdi, 1
+; 	mov rax, __NR_write
+; 	syscall
+;
+; 	ret
+; .spc: db " "
+
 ; interpret {{{
 ; 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
@@ -355,7 +372,7 @@ defcode "interpret", interpret, 0
 	jmp .loop
 
 .componly:
-	call q_notfound
+	call q_componly
 	jmp .loop
 
 .intrpnum:
@@ -1143,6 +1160,10 @@ defdefer "?overflow?", q_overflow, 0
 defdefer "?notfound?", q_notfound, 0
 	call abort
 	ret
+
+defdefer "?componly?", q_componly, 0
+	call abort
+	ret
 ; }}}
 
 ; these words are called from `create`d words,