Merge /home/anton/tmp/gforth

blocks.fs

@@ -226,7 +226,7 @@ Create block-input   A, A, A, A, A,
     \g Text-interpret block @i{u}.  Block 0 cannot be @code{load}ed.
     dup 0= -35 and throw
     block-input 0 new-tib dup loadline ! blk !  -3 loadfilename# !
-    ['] interpret catch pop-file throw ;
+    ['] interpret bt-rp0-catch pop-file throw ;
 
 : thru ( i*x n1 n2 -- j*x ) \ block-ext
     \G @code{load} the blocks @i{n1} through @i{n2} in sequence.

debugs.fs

@@ -102,11 +102,27 @@ $10 stack: cov-stack
 
 \ launch a debug shell, quit with emtpy line
 
+[ifundef] bt-rp0-catch
+: bt-rp0-catch ( ... xt -- ... ball )
+    backtrace-rp0 @ >r	
+    catch
+    r> backtrace-rp0 ! ;
+
+: bt-rp0-wrapper ( ... xt -- ... )
+    bt-rp0-catch throw ;
+[then]
+
+: ???-loop ( ... -- ... )
+    BEGIN
+        ." dbg> " refill  WHILE
+            source nip WHILE
+                interpret ."  ok" cr
+        REPEAT  THEN ;
+
 : ??? ( -- )
     \G Open a debuging shell
     create-input cr
-    BEGIN  ." dbg> " refill  WHILE  source nip WHILE
-		interpret ."  ok" cr  REPEAT  THEN
+    ['] ???-loop bt-rp0-catch throw
     0 pop-file drop ;
 ' ??? alias dbg-shell
 

fget.fs

@@ -55,7 +55,7 @@ Variable maxnum
     #tib @ 1 >= IF  source 1- + c@ #cr = #tib +!  THEN ;
 : refill-loop ( -- flag )
     base @ >r base off
-    BEGIN  refill ?cr  WHILE  ['] interpret catch drop  >in @ 0=  UNTIL
+    BEGIN  refill ?cr  WHILE  ['] interpret bt-rp0-catch drop  >in @ 0=  UNTIL
 	true  ELSE  maxnum off false  THEN  r> base ! ;
 
 : response:  ( -- )

httpd.fs

@@ -120,7 +120,7 @@ Variable maxnum
   #tib @ 1 >= IF  source 1- + c@ #cr = #tib +!  THEN ;
 : refill-loop ( -- flag )
   base @ >r base off
-  BEGIN  refill ?cr  WHILE  ['] interpret catch drop  >in @ 0=  UNTIL
+  BEGIN  refill ?cr  WHILE  ['] interpret bt-rp0-catch drop  >in @ 0=  UNTIL
   true  ELSE  maxnum off false  THEN  r> base ! ;
 : get-input ( -- flag ior )
   s" /nosuchfile" url $!  s" HTTP/1.0" protocol $!

kernel/args.fs

@@ -84,8 +84,10 @@ Variable argc ( -- addr ) \ gforth
 : args-required ( i*x addr u -- i*x ) \ gforth
     2dup ['] args-required1 os-execute-parsing ;
 
+: interpret2 ['] interpret bt-rp0-wrapper ;
+
 : args-evaluate ( i*x addr u -- j*x ) \ gforth
-    ['] interpret os-execute-parsing ;
+    ['] interpret2 os-execute-parsing ;
 
 \ main words
 

kernel/input.fs

@@ -159,7 +159,7 @@ terminal-input @       \ source -> terminal-input::source
 \G @code{0} and make the string @i{c-addr u} the input source and
 \G input buffer. Interpret. When the parse area is empty, restore the
 \G input source specification.
-    ['] interpret execute-parsing ;
+    ['] interpret2 execute-parsing ;
 
 \ clear tibstack
 
@@ -181,10 +181,13 @@ defer line-end-hook ( -- ) \ gforth
 \G called at every end-of-line when text-interpreting from a file    
 \ alternatively we could use a wrapper for REFILL
 ' noop is line-end-hook
-    
+
+: read-loop1 ( i*x -- j*x )
+    BEGIN  refill  WHILE  interpret line-end-hook REPEAT ;
+
 : read-loop ( i*x -- j*x ) \ gforth
     \G refill and interpret a file until EOF
-    BEGIN  refill  WHILE  interpret line-end-hook REPEAT
+    ['] read-loop1 bt-rp0-wrapper
     state @ warning" EOF reached while compiling" ;
 
 : get-input ( -- flag ) \ gforth

kernel/int.fs

@@ -583,22 +583,26 @@ defer int-execute ( ... xt -- ... )
 \ like EXECUTE, but restores and saves ERRNO if present
 ' execute IS int-execute
 
-: interpret1 ( ... -- ... )
-    rp@ backtrace-rp0 !
+: interpret ( ... -- ... ) \ gforth
+    \ interpret/compile the (rest of the) input buffer
+    r> >l rp@ backtrace-rp0 !
     [ has? EC 0= [IF] ] before-line [ [THEN] ]
     BEGIN
 	?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
     WHILE
 	parser1 int-execute
     REPEAT
-    2drop ;
+    2drop @local0 >r lp+ ;
     
-: interpret ( ?? -- ?? ) \ gforth
-    \ interpret/compile the (rest of the) input buffer
+: bt-rp0-catch ( ... xt -- ... ball )
     backtrace-rp0 @ >r	
-    ['] interpret1 catch
-    r> backtrace-rp0 !
-    throw ;
+    catch
+    r> backtrace-rp0 ! ;
+
+: bt-rp0-wrapper ( ... xt -- ... )
+    bt-rp0-catch throw ;
+
+: interpret2 ['] interpret bt-rp0-wrapper ;
 
 \ interpreter                                 	30apr92py
 
@@ -650,7 +654,7 @@ defer prompt
     ."  ok" ;
 ' (prompt) is prompt
 
-: (quit) ( -- )
+: (quit1) ( -- )
     \ exits only through THROW etc.
     BEGIN
 	[ has? ec [IF] ] cr [ [ELSE] ]
@@ -662,8 +666,10 @@ defer prompt
 	endif [ [THEN] ]
 	get-input-colored WHILE
 	    interpret prompt
-    REPEAT
-    bye ;
+    REPEAT ;
+
+: (quit) ( -- )
+    ['] (quit1) bt-rp0-wrapper bye ;
 
 ' (quit) IS 'quit
 

kernel/saccept.fs

@@ -51,7 +51,7 @@ Variable echo  -1 echo !
 : included ( addr u -- )
     2 emit dup $20 + emit type
     echo @ IF
-	echo off ['] refill-loop catch
+	echo off ['] refill-loop bt-rp0-catch
 	dup IF  4 emit  THEN  echo on  throw
     THEN ;
 : include ( "file" -- )  parse-name included ;

wf.fs

@@ -588,7 +588,7 @@ longtags set-current
 : red> -env ;
 : >>  -env ;
 : *> ;
-: ::  interpret ;
+: ::  ['] interpret bt-rp0-wrapper ;
 : .   end-sec on 0 indent ;
 : :code s" pre" >env
     BEGIN  source >in @ /string .type cr refill  WHILE