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