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