forth/lib/locals.fs

\ tag: local variables
\ 
\ Copyright (C) 2012 Mark Cave-Ayland
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\

[IFDEF] CONFIG_LOCALS

\ Init local variable stack
variable locals-var-stack
here 200 cells allot locals-var-stack !

\ Set initial stack pointer
\
\ Stack looks like this:
\ ... (sp n-2) local1 ... localm-1 localm (sp n-1)  <-- sp

locals-var-stack @ value locals-var-sp
locals-var-sp locals-var-stack @ !

0 value locals-var-count
0 value locals-flags

here 200 cells allot locals-dict-buf !

8 constant #locals

: (local1) locals-var-sp @ /n + ;
: (local2) locals-var-sp @ 2 cells + ;
: (local3) locals-var-sp @ 3 cells + ;
: (local4) locals-var-sp @ 4 cells + ;
: (local5) locals-var-sp @ 5 cells + ;
: (local6) locals-var-sp @ 6 cells + ;
: (local7) locals-var-sp @ 7 cells + ;
: (local8) locals-var-sp @ 8 cells + ;

: local1@ (local1) @ ;
: local2@ (local2) @ ;
: local3@ (local3) @ ;
: local4@ (local4) @ ;
: local5@ (local5) @ ;
: local6@ (local6) @ ;
: local7@ (local7) @ ;
: local8@ (local8) @ ;

: local1! (local1) ! ;
: local2! (local2) ! ;
: local3! (local3) ! ;
: local4! (local4) ! ;
: local5! (local5) ! ;
: local6! (local6) ! ;
: local7! (local7) ! ;
: local8! (local8) ! ;

create locals-read-table
['] local1@ ,
['] local2@ ,
['] local3@ ,
['] local4@ ,
['] local5@ ,
['] local6@ ,
['] local7@ ,
['] local8@ ,

create locals-write-table
['] local1! ,
['] local2! ,
['] local3! ,
['] local4! ,
['] local5! ,
['] local6! ,
['] local7! ,
['] local8! ,


: locals-push ( n -- )
  locals-var-sp /n + to locals-var-sp
  locals-var-sp !
;

: locals-0-push ( -- )
  0 locals-push
;
  
: (apply-local-flags) ( lfa -- )
  1 - dup c@ locals-flags or swap c!
;  

: locals-no-pop? ( lfa -- ? )
  1 - c@ 8 and 0<>
;

: locals-drop      \ Destroy current stack frame
  locals-var-sp @ to locals-var-sp
;

['] locals-drop to locals-end

: (local-init) ( str len -- )
  header 1 , 		 \ DOCOL
  ['] (lit) , ['] noop , \ read-xt
  ['] (lit) , ['] noop , \ write-xt
  ['] 2drop ,		 \ do nothing
  ['] (lit) ,
  here 5 cells - ,
  ['] @ , ['] , ,   \ store read-xt
  ['] (semis) ,
  reveal
  immediate
  last @ (apply-local-flags)
;

: (local-noop) ( str len -- )
  2drop
;

\ Word called when consuming a local variable
defer (local)

: } ( C: current latest here -- )
  here! latest ! current !           \ Switch back to normal dict
  locals-dict-buf @ to locals-dict   \ Make locals-dict visible to $find
  0 to locals-var-count
  ['] locals-var-sp ,    \ save previous sp on rstack
  ['] >r ,
  locals-dict @    \ ( last -- )
  begin
    ?dup 0<>
  while
    >r
    locals-var-count /n *
    locals-read-table + @ r@ 3 cells + !    \ set read-xt
    locals-var-count /n *
    locals-write-table + @ r@ 5 cells + !   \ set write-xt
    locals-var-count 1+ to locals-var-count
    r@ locals-no-pop? if
      ['] locals-0-push ,    \ initialise with 0
    else
      ['] locals-push ,      \ initialise from stack
    then
    r> @  \ next lfa
  repeat
  ['] r> ,
  ['] locals-push ,   \ write previous sp
; immediate

: { ( C: -- current latest here )
  current @ latest @ here
  ['] (local-init) to (local)
  0 to locals-flags
  0 to locals-var-count
  locals-dict-buf @ 200 cells 0 fill    \ Zero out temporary dictionary
  locals-dict-buf @ current !     \ Switch to locals dictionary
  locals-dict-buf @ /n + here!
  
  begin
    parse-word
    2dup s" }" strcmp 0= if
      2drop
      ['] } execute -1
    else
      2dup s" ;" strcmp 0= if
        2drop
        8 to locals-flags 0  \ Don't init from stack
      else     
        2dup s" |" strcmp 0= if
          2drop
          8 to locals-flags 0   \ Don't init from stack
        else    
          2dup s" --" strcmp 0= if
            2drop
            ['] (local-noop) to (local) 0
          else
            locals-var-count #locals < if
              (local) 0    \ accept local
            else
              s" maximum locals used ignoring " type type cr 0
            then
	    locals-var-count 1+ to locals-var-count
          then
        then
      then
    then
  until
; immediate

: -> ( n -- )
  parse-word $find if
    4 cells + @ ,
  else
    s" unable to find word " type type
  then
; immediate

[THEN]