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

1 files changed, 79 insertions, 8 deletions

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