From f0642252d3d8a08c981a6709b978abbd3e6a3106 Mon Sep 17 00:00:00 2001
From: Brad Nelson <flagxor@gmail.com>
Date: Sat, 10 Jul 2021 18:11:08 -0700
Subject: [PATCH] Fixed TO for locals.

---
 ueforth/common/boot.fs         |  8 ++++----
 ueforth/common/locals.fs       | 23 +++++++++++++++++------
 ueforth/common/locals_tests.fs | 12 ++++++++++++
 3 files changed, 33 insertions(+), 10 deletions(-)

diff --git a/ueforth/common/boot.fs b/ueforth/common/boot.fs
index 822c572..6024052 100644
--- a/ueforth/common/boot.fs
+++ b/ueforth/common/boot.fs
@@ -158,10 +158,10 @@ variable handler
 
 ( Values )
 : value ( n -- ) create , does> @ ;
-: to ( n -- )
-   ' >body state @ if aliteral postpone ! else ! then ; immediate
-: +to ( n -- )
-   ' >body state @ if aliteral postpone +! else +! then ; immediate
+: value-bind ( xt-val xt )
+   >r >body state @ if aliteral r> , else r> execute then ;
+: to ( n -- ) ' ['] ! value-bind ; immediate
+: +to ( n -- ) ' ['] +! value-bind ; immediate
 
 ( Deferred Words )
 : defer ( "name" -- ) create 0 , does> @ dup 0= throw execute ;
diff --git a/ueforth/common/locals.fs b/ueforth/common/locals.fs
index c8a4065..5a12d9f 100644
--- a/ueforth/common/locals.fs
+++ b/ueforth/common/locals.fs
@@ -24,18 +24,23 @@ create locals-area locals-capacity allot
 variable locals-here  locals-area locals-here !
 : <>locals   locals-here @ here locals-here ! here - allot ;
 
-variable scope-depth
-: scope-clear
-   begin scope-depth @ while postpone rdrop cell scope-depth +! repeat
-   0 scope !   locals-area locals-here ! ;
 : local@ ( n -- ) rp@ + @ ;
-: do-local ( n -- ) nest-depth @ 1+ cells - aliteral ['] local@ , ;
+: local! ( n -- ) rp@ + ! ;
+: local+! ( n -- ) rp@ + +! ;
+
+variable scope-depth
+variable local-op   ' local@ local-op !
+: scope-clear
+   scope-depth @ for aft postpone rdrop then next
+   0 scope-depth !   0 scope !   locals-area locals-here ! ;
+: do-local ( n -- ) nest-depth @ + 1+ cells negate aliteral
+                    local-op @ ,  ['] local@ local-op ! ;
 : scope-create ( a n -- )
    dup >r $place align r> , ( name )
    scope @ , 1 , ( IMMEDIATE ) here scope ! ( link, flags )
    ['] scope-clear @ ( docol) ,
    scope-depth @ aliteral postpone do-local ['] exit ,
-   cell negate scope-depth +!
+   1 scope-depth +!
 ;
 
 : ?room   locals-here @ locals-area - locals-capacity locals-gap - >
@@ -46,6 +51,9 @@ variable scope-depth
 : }? ( a n -- ) 1 <> if drop 0 exit then c@ [char] } = ;
 : --? ( a n -- ) s" --" str= ;
 
+: (to) ( xt -- ) ['] local! local-op ! execute ;
+: (+to) ( xt -- ) ['] local+! local-op ! execute ;
+
 also forth definitions
 
 : {   begin bl parse
@@ -53,6 +61,9 @@ also forth definitions
         2dup --? if 2drop [char] } parse 2drop exit then
         2dup }? if 2drop exit then
       (local) again ; immediate
+( TODO: Hide the words overriden here. )
 : ;   scope-clear postpone ; ; immediate
+: to ( n -- ) ' dup >flags @ if (to) else ['] ! value-bind then ; immediate
+: +to ( n -- ) ' dup >flags @ if (+to) else ['] +! value-bind then ; immediate
 
 only forth definitions
diff --git a/ueforth/common/locals_tests.fs b/ueforth/common/locals_tests.fs
index 4b5dfc7..dd4ab71 100644
--- a/ueforth/common/locals_tests.fs
+++ b/ueforth/common/locals_tests.fs
@@ -59,3 +59,15 @@ e: test-do-+loop
   99 999 test
   out: 0 99 999 2 99 999 4 99 999 6 99 999 8 99 999 
 ;e
+
+e: test-to
+  : test 0 { a b } 123 to b a . b . cr ;
+  3 test 
+  out: 3 123 
+;e
+
+e: test-to-loop
+  : test 0 { x } 5 0 do i i * to x x . loop cr ;
+  test
+  out: 0 1 4 9 16 
+;e