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

[Mark Cave-Ayland]

On 09/08/11 22:55, William Hahne wrote:

> 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
>

Very interesting. I think this needs someone with quite strong Forth-fu 
(Stefan) to review this one. Also I can't see any related documentation 
with this patch related to locals support?


ATB,

Mark.

-- 
Mark Cave-Ayland - Senior Technical Architect
PostgreSQL - PostGIS
Sirius Corporation plc - control through freedom
http://www.siriusit.co.uk
t: +44 870 608 0063

Sirius Labs: http://www.siriusit.co.uk/labs