diff options
Diffstat (limited to 'src/roms/SLOF/slof/fs/fcode/core.fs')
| -rw-r--r-- | src/roms/SLOF/slof/fs/fcode/core.fs | 173 |
1 files changed, 173 insertions, 0 deletions
diff --git a/src/roms/SLOF/slof/fs/fcode/core.fs b/src/roms/SLOF/slof/fs/fcode/core.fs new file mode 100644 index 0000000..8fd98ec --- /dev/null +++ b/src/roms/SLOF/slof/fs/fcode/core.fs @@ -0,0 +1,173 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 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 +\ ****************************************************************************/ + +: ?offset16 ( -- true|false ) + fcode-offset 2 = + ; + +: ?arch64 ( -- true|false ) + cell 8 = + ; + +: ?bigendian ( -- true|false ) + deadbeef fcode-num ! + fcode-num ?arch64 IF 4 + THEN + c@ de = + ; + +: reset-fcode-end ( -- ) + false fcode-end ! + ; + +: get-ip ( -- n ) + ip @ + ; + +: set-ip ( n -- ) + ip ! + ; + +: next-ip ( -- ) + get-ip 1+ set-ip + ; + +: jump-n-ip ( n -- ) + get-ip + set-ip + ; + +: read-byte ( -- n ) + get-ip fcode-rb@ + ; + +: ?compile-mode ( -- on|off ) + state @ + ; + +: save-evaluator-state + get-ip eva-debug? IF ." saved ip " dup . cr THEN + fcode-end @ eva-debug? IF ." saved fcode-end " dup . cr THEN + fcode-offset eva-debug? IF ." saved fcode-offset " dup . cr THEN +\ local fcodes are currently NOT saved! + fcode-spread eva-debug? IF ." saved fcode-spread " dup . cr THEN + ['] fcode@ behavior eva-debug? IF ." saved fcode@ " dup . cr THEN + ; + +: restore-evaluator-state + eva-debug? IF ." restored fcode@ " dup . cr THEN to fcode@ + eva-debug? IF ." restored fcode-spread " dup . cr THEN to fcode-spread +\ local fcodes are currently NOT restored! + eva-debug? IF ." restored fcode-offset " dup . cr THEN to fcode-offset + eva-debug? IF ." restored fcode-end " dup . cr THEN fcode-end ! + eva-debug? IF ." restored ip " dup . cr THEN set-ip + ; + +: token-table-index ( fcode# -- addr ) + cells token-table + + ; + +: join-immediate ( xt immediate? addr -- xt+immediate? addr ) + -rot + swap + ; + +: split-immediate ( xt+immediate? -- xt immediate? ) + dup 1 and 2dup - rot drop swap + ; + +: literal, ( n -- ) + postpone literal + ; + +: fc-string, + postpone sliteral + dup c, bounds ?do i c@ c, loop + ; + +: set-token ( xt immediate? fcode# -- ) + token-table-index join-immediate ! + ; + +: get-token ( fcode# -- xt immediate? ) + token-table-index @ split-immediate + ; + +( ---------------------------------------------------- ) + +#include "little-big.fs" + +( ---------------------------------------------------- ) + +: read-fcode# ( -- FCode# ) + read-byte + dup 01 0F between IF drop read-fcode-num16 THEN + ; + +: read-header ( adr -- ) + next-ip read-byte drop + next-ip read-fcode-num16 drop + next-ip read-fcode-num32 drop + ; + +: read-fcode-string ( -- str len ) + read-byte \ get string length ( -- len ) + next-ip get-ip \ get string addr ( -- len str ) + swap \ type needs the parameters swapped ( -- str len ) + dup 1- jump-n-ip \ jump to the end of the string in FCode + ; + + +-1 VALUE break-fcode-addr +0 VALUE break-fcode-steps + +: evaluate-fcode ( -- ) + BEGIN + get-ip break-fcode-addr = IF + TRUE fcode-end ! + THEN + fcode-end @ 0= + WHILE + fcode@ ( fcode# ) + eva-debug? IF + dup + get-ip 8 u.r ." : " + ." [" 3 u.r ." ] " + THEN + \ When it is not immediate and in compile-mode, then compile + get-token 0= ?compile-mode AND IF ( xt ) + compile, + ELSE \ immediate or "interpretation" mode + eva-debug? IF dup xt>name type space THEN + execute + THEN + eva-debug? IF .s cr THEN + break-fcode-steps IF + break-fcode-steps 1- TO break-fcode-steps + break-fcode-steps 0= IF + TRUE fcode-end ! + THEN + THEN + next-ip + REPEAT +; + +\ Run FCODE for n steps +: steps-fcode ( n -- ) + to break-fcode-steps + break-fcode-addr >r -1 to break-fcode-addr + reset-fcode-end + evaluate-fcode + r> to break-fcode-addr +; + +\ Step through one FCODE instruction +: step-fcode ( -- ) + 1 steps-fcode +; |
