Some bootloaders, particularly OS X, execute Forth strings that make use of Forth local variables. This patch provides an implementation that allows OpenBIOS to execute such code.
A couple of examples are included below:
: diff.squares { A B -- A*A-B*B } A A * B B * - ;
: myword { ; cat dog } 4 -> cat 5 -> dog
cat \ cat's value pushed onto stack ( - cat) dog \ dog's value pushed onto stack (cat - cat dog ) +
cr ." Total animals = " . cr ;
Since the Forth locals stack and temporary dictionary take up extra space, the locals implementation is protected by a new CONFIG_LOCALS build variable.
Signed-off-by: Mark Cave-Ayland mark.cave-ayland@ilande.co.uk --- openbios-devel/forth/bootstrap/bootstrap.fs | 13 ++ openbios-devel/forth/lib/build.xml | 1 + openbios-devel/forth/lib/locals.fs | 197 +++++++++++++++++++++++++++ 3 files changed, 211 insertions(+) create mode 100644 openbios-devel/forth/lib/locals.fs
diff --git a/openbios-devel/forth/bootstrap/bootstrap.fs b/openbios-devel/forth/bootstrap/bootstrap.fs index 08683f0..f295e4e 100644 --- a/openbios-devel/forth/bootstrap/bootstrap.fs +++ b/openbios-devel/forth/bootstrap/bootstrap.fs @@ -49,6 +49,10 @@ variable #order 0 #order ! defer context 0 value vocabularies?
+defer locals-end +0 value locals-dict +variable locals-dict-buf + \ \ 7.3.7 Flag constants \ @@ -925,6 +929,11 @@ variable #out 0 #out ! ;
: $find ( name-str name-len -- xt true | name-str name-len false ) + locals-dict 0<> if + locals-dict-buf @ find-wordlist ?dup if + exit + then + then vocabularies? if #order @ 0 ?do i cells context + @ @@ -1426,6 +1435,10 @@ false value capital-hex? ;
: ; + locals-dict 0<> if + 0 ['] locals-dict /n + ! + ['] locals-end , + then ['] (semis) , reveal ['] [ execute ; immediate
diff --git a/openbios-devel/forth/lib/build.xml b/openbios-devel/forth/lib/build.xml index 8c353ff..34eee40 100644 --- a/openbios-devel/forth/lib/build.xml +++ b/openbios-devel/forth/lib/build.xml @@ -16,6 +16,7 @@ <object source="split.fs"/> <object source="lists.fs"/> <object source="64bit.fs"/> + <object source="locals.fs"/> </dictionary>
</build> diff --git a/openbios-devel/forth/lib/locals.fs b/openbios-devel/forth/lib/locals.fs new file mode 100644 index 0000000..e697383 --- /dev/null +++ b/openbios-devel/forth/lib/locals.fs @@ -0,0 +1,197 @@ +\ 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]