--- gforth/Attic/kernal.fs	1994/10/18 15:51:19	1.21
+++ gforth/Attic/kernal.fs	1994/11/15 15:55:39	1.24
@@ -1,4 +1,4 @@
-\ KERNAL.FS    ANS figFORTH kernal                     17dec92py
+\ KERNAL.FS    GNU FORTH kernal                        17dec92py
 \ $ID:
 \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group
@@ -66,7 +66,7 @@ DOES> ( n -- )  + c@ ;
       bl c,
   LOOP ;
 
-
+: chars ; immediate
 
 : A!    ( addr1 addr2 -- )  dup relon ! ;
 : A,    ( addr -- )     here cell allot A! ;
@@ -173,10 +173,10 @@ Defer source
 : [char] ( 'char' -- n )  char postpone Literal ; immediate
 ' [char] Alias Ascii immediate
 
-: (compile) ( -- )  r> dup cell+ >r @ A, ;
+: (compile) ( -- )  r> dup cell+ >r @ compile, ;
 : postpone ( "name" -- )
   name sfind dup 0= abort" Can't compile "
-  0> IF  A,  ELSE  postpone (compile) A,  THEN ;
+  0> IF  compile,  ELSE  postpone (compile) A,  THEN ;
                                              immediate restrict
 
 \ Use (compile) for the old behavior of compile!
@@ -244,6 +244,9 @@ decimal
 Create spaces  bl 80 times \ times from target compiler! 11may93jaw
 DOES>   ( u -- )  swap
         0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
+Create backspaces  08 80 times \ times from target compiler! 11may93jaw
+DOES>   ( u -- )  swap
+        0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
 hex
 : space   1 spaces ;
 
@@ -417,11 +420,23 @@ AConstant locals-list \ acts like a vari
 
 
 variable dead-code \ true if normal code at "here" would be dead
-
-: unreachable ( -- )
-\ declares the current point of execution as unreachable
- dead-code on ;
-
+variable backedge-locals
+    \ contains the locals list that BEGIN will assume to be live on
+    \ the back edge if the BEGIN is unreachable from above. Set by
+    \ ASSUME-LIVE, reset by UNREACHABLE.
+
+: UNREACHABLE ( -- )
+    \ declares the current point of execution as unreachable
+    dead-code on
+    0 backedge-locals ! ; immediate
+
+: ASSUME-LIVE ( orig -- orig )
+    \ used immediateliy before a BEGIN that is not reachable from
+    \ above.  causes the BEGIN to assume that the same locals are live
+    \ as at the orig point
+    dup orig?
+    2 pick backedge-locals ! ; immediate
+    
 \ locals list operations
 
 : common-list ( list1 list2 -- list3 )
@@ -546,7 +561,7 @@ variable dead-code \ true if normal code
 \ Structural Conditionals                              12dec92py
 
 : AHEAD ( -- orig )
- POSTPONE branch >mark unreachable ; immediate restrict
+ POSTPONE branch >mark POSTPONE unreachable ; immediate restrict
 
 : IF ( -- orig )
  POSTPONE ?branch >mark ; immediate restrict
@@ -588,17 +603,10 @@ variable dead-code \ true if normal code
 
 : BEGIN ( -- dest )
     dead-code @ if
-	\ set up an assumption of the locals visible here
-	\ currently we just take the top cs-item
-	\ it would be more intelligent to take the top orig
-	\   but that can be arranged by the user
-	dup defstart <> if
-	    dup cs-item?
-	    2 pick
-	else
-	    0
-	then
-	set-locals-size-list
+	\ set up an assumption of the locals visible here.  if the
+	\ users want something to be visible, they have to declare
+	\ that using ASSUME-LIVE
+	backedge-locals @ set-locals-size-list
     then
     cs-push-part dest
     dead-code off ; immediate restrict
@@ -614,7 +622,7 @@ variable dead-code \ true if normal code
     POSTPONE branch
     <resolve
     check-begin
-    unreachable ; immediate restrict
+    POSTPONE unreachable ; immediate restrict
 
 \ UNTIL (the current control flow may join an earlier one or continue):
 \ Similar to AGAIN. The new locals-list and locals-size are the current
@@ -746,7 +754,7 @@ Avariable leave-sp  leave-stack 3 cells
 : EXIT ( -- )
     0 adjust-locals-size
     POSTPONE ;s
-    unreachable ; immediate restrict
+    POSTPONE unreachable ; immediate restrict
 
 : ?EXIT ( -- )
      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
@@ -1033,7 +1041,7 @@ Variable warnings  G -1 warnings T !
 
 : bell  #bell emit ;
 
-: backspaces  0 ?DO  #bs emit  LOOP ;
+\ : backspaces  0 ?DO  #bs emit  LOOP ;
 : >string  ( span addr pos1 -- span addr pos1 addr2 len )
   over 3 pick 2 pick chars /string ;
 : type-rest ( span addr pos1 -- span addr pos1 back )
@@ -1396,7 +1404,10 @@ Variable argc
 	THEN
     +LOOP ;
 
+Defer 'cold ' noop IS 'cold
+
 : cold ( -- )
+    'cold
     pathstring 2@ process-path pathdirs 2!
     argc @ 1 >
     IF