FCODE: Support for old-fashioned "local values" tokens

One of the old FCODE tokenizers uses the opcodes in the range of 0x407 to 0x41f
for supporting Forth local values. To get these FCODE programs working, we have
to support these opcodes, too.

Signed-off-by: Thomas Huth <thuth@linux.vnet.ibm.com>

2 files changed, 156 insertions, 0 deletions

diff --git a/slof/fs/fcode/evaluator.fs b/slof/fs/fcode/evaluator.fs
index 2a82a78..8f0bae5 100644
--- a/slof/fs/fcode/evaluator.fs
+++ b/slof/fs/fcode/evaluator.fs
@@ -28,6 +28,7 @@ create token-table 2000 cells allot    \ 1000h = 4096d
 #include "core.fs"
 #include "1275.fs"
 #include "tokens.fs"
+#include "locals.fs"
 
 0 value buff
 0 value buff-size
diff --git a/slof/fs/fcode/locals.fs b/slof/fs/fcode/locals.fs
new file mode 100644
index 0000000..5381df0
--- /dev/null
+++ b/slof/fs/fcode/locals.fs
@@ -0,0 +1,155 @@
+\ *****************************************************************************
+\ * Copyright (c) 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ *     IBM Corporation - initial implementation
+\ ****************************************************************************/
+\ *
+\ * Support for old-fashioned local values in FCODE.
+\ *
+\ * There is one old FCODE tokenizer that uses the FCODE opcodes in the range
+\ * of 0x407 to 0x41f for supporting Forth local values. Each locals stack
+\ * frame contains 8 variables. The opcodes from 0x407 to 0x40f are used to
+\ * push 0 up to 8 values from the normal data stack into the current locals
+\ * stack frame. All other variables in the current stack frame are not
+\ * pre-initialized.
+\ * The opcodes from 0x410 to 0x417 can be used for reading the first, second,
+\ * ... eighth value out of the locals stack frame, and the opcode from 0x418
+\ * to 0x41f can be used to set the first, second, ... eighth value in the
+\ * stack frame respectively.
+\ *
+
+80 cells CONSTANT LOCALS-STACK-SIZE
+
+LOCALS-STACK-SIZE BUFFER: localsstackbuf
+
+localsstackbuf VALUE localsstack
+
+
+: fc-local@  ( n -- val )
+   cells localsstack swap - @
+;
+
+: fc-local-1-@  1 fc-local@ ;
+: fc-local-2-@  2 fc-local@ ;
+: fc-local-3-@  3 fc-local@ ;
+: fc-local-4-@  4 fc-local@ ;
+: fc-local-5-@  5 fc-local@ ;
+: fc-local-6-@  6 fc-local@ ;
+: fc-local-7-@  7 fc-local@ ;
+: fc-local-8-@  8 fc-local@ ;
+
+
+: fc-local!  ( val n -- )
+   cells localsstack swap - !
+;
+
+: fc-local-1-!  1 fc-local! ;
+: fc-local-2-!  2 fc-local! ;
+: fc-local-3-!  3 fc-local! ;
+: fc-local-4-!  4 fc-local! ;
+: fc-local-5-!  5 fc-local! ;
+: fc-local-6-!  6 fc-local! ;
+: fc-local-7-!  7 fc-local! ;
+: fc-local-8-!  8 fc-local! ;
+
+
+0 VALUE uses-locals?
+
+\ Create space for the current function on the locals stack.
+\ Pre-initialized the n first locals with the n top-most data stack items.
+\ Note: Each function can use up to 8 (initialized or uninitialized) locals.
+: (fc-push-locals)  ( ... n -- )
+   \ cr ." pushing " dup . ." locals" cr
+   8 cells localsstack + TO localsstack
+   localsstack localsstackbuf -
+   LOCALS-STACK-SIZE > ABORT" Locals stack exceeded!"
+   ?dup IF
+      ( ... n ) 1 swap DO
+         i fc-local!              \ Store pre-initialized locals
+      -1 +LOOP
+   THEN
+;
+
+: fc-push-locals  ( n -- )
+   \ cr ." compiling push for " dup . ." locals" cr
+   uses-locals? ABORT" Definition pushes locals multiple times!"
+   true TO uses-locals?
+   ( n ) ['] literal execute
+   ['] (fc-push-locals) compile,
+;
+
+: fc-push-0-locals  0 fc-push-locals ;
+: fc-push-1-locals  1 fc-push-locals ;
+: fc-push-2-locals  2 fc-push-locals ;
+: fc-push-3-locals  3 fc-push-locals ;
+: fc-push-4-locals  4 fc-push-locals ;
+: fc-push-5-locals  5 fc-push-locals ;
+: fc-push-6-locals  6 fc-push-locals ;
+: fc-push-7-locals  7 fc-push-locals ;
+: fc-push-8-locals  8 fc-push-locals ;
+
+
+: fc-pop-locals  ( -- )
+   \ ." popping locals" cr
+   localsstack 8 cells - TO localsstack
+   localsstack localsstackbuf - 0 < ABORT" Locals stack undeflow!"
+;
+
+
+: fc-locals-exit
+   uses-locals? IF
+      \ ." compiling pop-locals for exit" cr
+      ['] fc-pop-locals compile,
+   THEN
+   ['] exit compile,
+;
+
+: fc-locals-b(;)
+   uses-locals? IF
+      \ ." compiling pop-locals for b(;)" cr
+      ['] fc-pop-locals compile,
+   THEN
+   false TO uses-locals?
+   ['] b(;) execute
+;
+
+
+: fc-set-locals-tokens  ( -- )
+   ['] fc-push-0-locals 1 407 set-token
+   ['] fc-push-1-locals 1 408 set-token
+   ['] fc-push-2-locals 1 409 set-token
+   ['] fc-push-3-locals 1 40a set-token
+   ['] fc-push-4-locals 1 40b set-token
+   ['] fc-push-5-locals 1 40c set-token
+   ['] fc-push-6-locals 1 40d set-token
+   ['] fc-push-7-locals 1 40e set-token
+   ['] fc-push-8-locals 1 40f set-token
+
+   ['] fc-local-1-@ 0 410 set-token
+   ['] fc-local-2-@ 0 411 set-token
+   ['] fc-local-3-@ 0 412 set-token
+   ['] fc-local-4-@ 0 413 set-token
+   ['] fc-local-5-@ 0 414 set-token
+   ['] fc-local-6-@ 0 415 set-token
+   ['] fc-local-7-@ 0 416 set-token
+   ['] fc-local-8-@ 0 417 set-token
+
+   ['] fc-local-1-! 0 418 set-token
+   ['] fc-local-2-! 0 419 set-token
+   ['] fc-local-3-! 0 41a set-token
+   ['] fc-local-4-! 0 41b set-token
+   ['] fc-local-5-! 0 41c set-token
+   ['] fc-local-6-! 0 41d set-token
+   ['] fc-local-7-! 0 41e set-token
+   ['] fc-local-8-! 0 41f set-token
+
+   ['] fc-locals-exit 1 33 set-token
+   ['] fc-locals-b(;) 1 c2 set-token
+;
+fc-set-locals-tokens