1\ ***************************************************************************** 2\ * Copyright (c) 2004, 2008 IBM Corporation 3\ * All rights reserved. 4\ * This program and the accompanying materials 5\ * are made available under the terms of the BSD License 6\ * which accompanies this distribution, and is available at 7\ * http://www.opensource.org/licenses/bsd-license.php 8\ * 9\ * Contributors: 10\ * IBM Corporation - initial implementation 11\ ****************************************************************************/ 12 13: ?offset16 ( -- true|false ) 14 fcode-offset 2 = 15 ; 16 17: ?arch64 ( -- true|false ) 18 cell 8 = 19 ; 20 21: ?bigendian ( -- true|false ) 22 deadbeef fcode-num ! 23 fcode-num ?arch64 IF 4 + THEN 24 c@ de = 25 ; 26 27: reset-fcode-end ( -- ) 28 false fcode-end ! 29 ; 30 31: get-ip ( -- n ) 32 ip @ 33 ; 34 35: set-ip ( n -- ) 36 ip ! 37 ; 38 39: next-ip ( -- ) 40 get-ip 1+ set-ip 41 ; 42 43: jump-n-ip ( n -- ) 44 get-ip + set-ip 45 ; 46 47: read-byte ( -- n ) 48 get-ip fcode-rb@ 49 ; 50 51: ?compile-mode ( -- on|off ) 52 state @ 53 ; 54 55: save-evaluator-state 56 get-ip eva-debug? IF ." saved ip " dup . cr THEN 57 fcode-end @ eva-debug? IF ." saved fcode-end " dup . cr THEN 58 fcode-offset eva-debug? IF ." saved fcode-offset " dup . cr THEN 59\ local fcodes are currently NOT saved! 60 fcode-spread eva-debug? IF ." saved fcode-spread " dup . cr THEN 61 ['] fcode@ behavior eva-debug? IF ." saved fcode@ " dup . cr THEN 62 ; 63 64: restore-evaluator-state 65 eva-debug? IF ." restored fcode@ " dup . cr THEN to fcode@ 66 eva-debug? IF ." restored fcode-spread " dup . cr THEN to fcode-spread 67\ local fcodes are currently NOT restored! 68 eva-debug? IF ." restored fcode-offset " dup . cr THEN to fcode-offset 69 eva-debug? IF ." restored fcode-end " dup . cr THEN fcode-end ! 70 eva-debug? IF ." restored ip " dup . cr THEN set-ip 71 ; 72 73: token-table-index ( fcode# -- addr ) 74 cells token-table + 75 ; 76 77: join-immediate ( xt immediate? addr -- xt+immediate? addr ) 78 -rot + swap 79 ; 80 81: split-immediate ( xt+immediate? -- xt immediate? ) 82 dup 1 and 2dup - rot drop swap 83 ; 84 85: literal, ( n -- ) 86 postpone literal 87 ; 88 89: fc-string, 90 postpone sliteral 91 dup c, bounds ?do i c@ c, loop 92 ; 93 94: set-token ( xt immediate? fcode# -- ) 95 token-table-index join-immediate ! 96 ; 97 98: get-token ( fcode# -- xt immediate? ) 99 token-table-index @ split-immediate 100 ; 101 102( ---------------------------------------------------- ) 103 104#include "little-big.fs" 105 106( ---------------------------------------------------- ) 107 108: read-fcode# ( -- FCode# ) 109 read-byte 110 dup 01 0F between IF drop read-fcode-num16 THEN 111 ; 112 113: read-header ( adr -- ) 114 next-ip read-byte drop 115 next-ip read-fcode-num16 drop 116 next-ip read-fcode-num32 drop 117 ; 118 119: read-fcode-string ( -- str len ) 120 read-byte \ get string length ( -- len ) 121 next-ip get-ip \ get string addr ( -- len str ) 122 swap \ type needs the parameters swapped ( -- str len ) 123 dup 1- jump-n-ip \ jump to the end of the string in FCode 124 ; 125 126 127-1 VALUE break-fcode-addr 1280 VALUE break-fcode-steps 129 130: evaluate-fcode ( -- ) 131 BEGIN 132 get-ip break-fcode-addr = IF 133 TRUE fcode-end ! 134 THEN 135 fcode-end @ 0= 136 WHILE 137 fcode@ ( fcode# ) 138 eva-debug? IF 139 dup 140 get-ip 8 u.r ." : " 141 ." [" 3 u.r ." ] " 142 THEN 143 \ When it is not immediate and in compile-mode, then compile 144 get-token 0= ?compile-mode AND IF ( xt ) 145 compile, 146 ELSE \ immediate or "interpretation" mode 147 eva-debug? IF dup xt>name type space THEN 148 execute 149 THEN 150 eva-debug? IF .s cr THEN 151 break-fcode-steps IF 152 break-fcode-steps 1- TO break-fcode-steps 153 break-fcode-steps 0= IF 154 TRUE fcode-end ! 155 THEN 156 THEN 157 next-ip 158 REPEAT 159; 160 161\ Run FCODE for n steps 162: steps-fcode ( n -- ) 163 to break-fcode-steps 164 break-fcode-addr >r -1 to break-fcode-addr 165 reset-fcode-end 166 evaluate-fcode 167 r> to break-fcode-addr 168; 169 170\ Step through one FCODE instruction 171: step-fcode ( -- ) 172 1 steps-fcode 173; 174