[PATCH 7/10] Apple local variables implementation in Forth

[William Hahne]

This is an implementation of Apple local variables which is required to
execute the Forth scripts in BootX

Index: forth/bootstrap/bootstrap.fs
===================================================================
--- forth/bootstrap/bootstrap.fs (revision 1041)
+++ forth/bootstrap/bootstrap.fs (working copy)
@@ -1413,10 +1413,135 @@
   here last @ , latest !            \ write backlink and set latest
  ;

+\
+\ Defer required by BootX
+\

+defer spin
+
+\
+\ Local Variables (Apple specific)
+\
+
+\
+: has-locals ( -- true/false )
+  skipws
+  ib >in @ + c@ 7b <>
+  if false exit then
+  ib >in @ + 1+ c@ 20 >
+  if false exit then
+
+  true
+ ;
+
+: comp-str-char ( str len char -- true/false )
+  swap 1 <> if 2drop false exit then
+  swap c@ <> if false exit then
+  true
+ ;
+
+variable locals_wordlist
+variable locals_state \ 0 - reading args
+                      \ 1 - ;
+                      \ 2 - reading vars
+: read-locals ( -- addr0 .. addrN addrCount )
+  has-locals
+  not if 0 false exit then \ no locals
+
+  0 locals_state !
+  0 >r
+
+  s" get-current" $find drop execute
+  s" wordlist" $find drop execute
+  dup locals_wordlist !
+  s" set-current" $find drop execute
+
+  parse-word 2drop \ ditch the {
+
+  begin
+    parse-word
+
+    2dup 3b comp-str-char \ check for ;
+    if 1 locals_state ! then
+
+    2dup 7d comp-str-char \ check for }
+    not
+  while
+    locals_state @ 1 <> if \ the ; is not a local variable so ignore it
+      header
+
+      locals_state @ 0= if \ only save the address if it is an arg
+        r>
+        here na1+ >r
+        1+ >r
+      then
+
+      3 , 0 ,
+      reveal
+    else \ if we hit a ; then move to next state
+      2drop
+      2 locals_state !
+    then
+  repeat
+
+  2drop
+
+  s" set-current" $find drop execute
+
+  r> 0
+  begin
+    2dup
+    >
+  while
+    r> -rot
+    1+
+  repeat
+
+  drop
+
+  true
+ ;
+
+: begin-locals ( addr0 .. addrN count hasLocals -- )
+  not if drop exit then
+
+  dup 0> if
+    0 do
+      ['] (lit) , , ['] ! ,
+    loop
+  else drop then
+
+  s" get-order" $find drop execute
+  locals_wordlist @
+  swap 1+
+  s" set-order" $find drop execute
+ ;
+
+: end-locals ( -- )
+  locals_wordlist @ 0= if exit then
+
+  0 locals_wordlist !
+
+  s" get-order" $find drop execute
+  swap drop 1-
+  s" set-order" $find drop execute
+ ;
+
+: -> parse-word $find drop na1+
+  ['] (lit) , , ['] ! ,
+ ; immediate
+
+\
+\ 7.3.9.1 Defining words
+\
+
 : :
-  parse-word header
-  1 , ]
 +  parse-word >r >r
+  read-locals
+  r> r> header
+  1 ,
+  begin-locals
+  ]
   ;

: :noname
@@ -1426,6 +1551,7 @@
   ;

: ;
+  end-locals
   ['] (semis) , reveal ['] [ execute
   ; immediate