| \ ***************************************************************************** |
| \ * 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 |
| ; |