diff options
Diffstat (limited to 'qemu/roms/openbios/forth/lib/locals.fs')
| -rw-r--r-- | qemu/roms/openbios/forth/lib/locals.fs | 197 |
1 files changed, 197 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/lib/locals.fs b/qemu/roms/openbios/forth/lib/locals.fs new file mode 100644 index 000000000..e697383b6 --- /dev/null +++ b/qemu/roms/openbios/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] |