1 |
5 |
howe.r.j.8 |
system +order 0 !
|
2 |
|
|
|
3 |
|
|
.( FORTH META COMPILATION START ) cr
|
4 |
|
|
|
5 |
|
|
\ ============================================================================
|
6 |
|
|
\ # The Meta-Compiler
|
7 |
|
|
\
|
8 |
|
|
only forth definitions hex
|
9 |
|
|
system +order 0 !
|
10 |
|
|
variable meta ( Metacompilation vocabulary )
|
11 |
|
|
meta +order definitions
|
12 |
|
|
variable assembler.1 ( Target assembler vocabulary )
|
13 |
|
|
variable target.1 ( Target dictionary )
|
14 |
|
|
variable tcp ( Target dictionary pointer )
|
15 |
|
|
variable tlast ( Last defined word in target )
|
16 |
|
|
variable tdoVar ( Location of doVar in target )
|
17 |
|
|
variable tdoConst ( Location of doConst in target )
|
18 |
|
|
variable tdoNext ( Location of doNext in target )
|
19 |
|
|
variable tdoPrintString ( Location of .string in target )
|
20 |
|
|
variable tdoStringLit ( Location of string-literal in target )
|
21 |
|
|
variable fence ( Do not peephole optimize before this point )
|
22 |
|
|
5000 constant #target ( Location where target image will be built )
|
23 |
|
|
2 constant =cell ( Target cell size )
|
24 |
|
|
$3A00 constant pad-area ( area for pad storage )
|
25 |
|
|
( 1 constant verbose ( verbosity level, higher is more verbose )
|
26 |
|
|
#target 2000 0 fill ( Erase the target memory location )
|
27 |
|
|
: ]asm assembler.1 +order ; immediate ( -- )
|
28 |
|
|
: a: current @ assembler.1 current ! : ; ( "name" -- wid link )
|
29 |
|
|
: a; [compile] ; current ! ; immediate ( wid link -- )
|
30 |
|
|
: ( [char] ) parse 2drop ; immediate ( "comment" -- discard until parenthesis )
|
31 |
|
|
: \ source drop @ >in ! ; immediate ( "comment" -- discard until end of line )
|
32 |
|
|
: there tcp @ ; ( -- a : target dictionary pointer value )
|
33 |
|
|
: tc! #target + c! ; ( u a -- : store character in target )
|
34 |
|
|
: tc@ #target + c@ ; ( a -- u : retrieve character in target )
|
35 |
|
|
: [last] tlast @ ; ( -- a : last defined word in target )
|
36 |
|
|
: t! over $FF and over tc! swap 8 rshift swap 1+ tc! ; ( u a -- )
|
37 |
|
|
: t@ dup tc@ swap 1+ tc@ 8 lshift or ; ( a -- u )
|
38 |
|
|
: 2/ 1 rshift ; ( u -- u : non-standard definition divide by 2 )
|
39 |
|
|
\ : 2* 1 lshift ; ( u -- u : multiple by two, non-standard )
|
40 |
|
|
: talign there 1 and tcp +! ; ( -- : align target dictionary pointer value )
|
41 |
|
|
: tc, there tc! 1 tcp +! ; ( c -- : write byte into target dictionary )
|
42 |
|
|
: t, there t! =cell tcp +! ; ( u -- : write cell into target dictionary )
|
43 |
|
|
\ : tallot tcp +! ; ( n -- : allocate memory in target dictionary )
|
44 |
|
|
: update-fence there fence ! ; ( -- : update optimizer fence location )
|
45 |
|
|
: $literal ( , -- )
|
46 |
|
|
[char] " word count dup tc, 1- for count tc, next drop talign update-fence ;
|
47 |
|
|
: tcells =cell * ; ( u -- a )
|
48 |
|
|
: tbody 1 tcells + ; ( a -- a )
|
49 |
|
|
: tcfa cfa ; ( PWD -- CFA )
|
50 |
|
|
: tnfa nfa ; ( PWD -- NFA )
|
51 |
|
|
: meta! ! ; ( u a -- )
|
52 |
|
|
: checksum #target there crc ; ( -- u : calculate CRC of target image )
|
53 |
|
|
: finished ( -- : save target image and display statistics )
|
54 |
|
|
hex
|
55 |
|
|
." COMPLETE" cr
|
56 |
|
|
." HOST: " here . cr
|
57 |
|
|
." TARGET: " there . cr
|
58 |
|
|
only forth definitions hex
|
59 |
|
|
." SAVING..." #target #target there + (save) throw ." DONE" cr
|
60 |
|
|
." STACK>" .s cr ;
|
61 |
|
|
: [a] ( "name" -- : find word and compile an assembler word )
|
62 |
|
|
bl word assembler.1 search-wordlist 0= abort" [a]? "
|
63 |
|
|
cfa compile, ; immediate
|
64 |
|
|
: asm[ assembler.1 -order ; immediate ( -- )
|
65 |
|
|
a: #literal $8000 a; ( literal instruction - top bit set )
|
66 |
|
|
a: #alu $6000 a; ( ALU instruction, further encoding below... )
|
67 |
|
|
a: #call $4000 a; ( function call instruction )
|
68 |
|
|
a: #?branch $2000 a; ( branch if zero instruction )
|
69 |
|
|
a: #branch $0000 a; ( unconditional branch )
|
70 |
|
|
|
71 |
|
|
a: #t $0000 a; ( T = t )
|
72 |
|
|
a: #n $0100 a; ( T = n )
|
73 |
|
|
a: #t+n $0200 a; ( T = t+n )
|
74 |
|
|
a: #t&n $0300 a; ( T = t&n )
|
75 |
|
|
a: #t|n $0400 a; ( T = t|n )
|
76 |
|
|
a: #t^n $0500 a; ( T = t^n )
|
77 |
|
|
a: #~t $0600 a; ( T = ~t )
|
78 |
|
|
a: #t==n $0700 a; ( T = n == t? )
|
79 |
|
|
a: #n
|
80 |
|
|
a: #n>>t $0900 a; ( T = n right shift by t places )
|
81 |
|
|
a: #t-1 $0A00 a; ( T == t - 1 )
|
82 |
|
|
a: #r $0B00 a; ( T = Top of Return Stack )
|
83 |
|
|
a: #[t] $0C00 a; ( T = memory[t] )
|
84 |
|
|
a: #n<
|
85 |
|
|
a: #sp@ $0E00 a; ( T = depth )
|
86 |
|
|
a: #nu
|
87 |
|
|
a: #cpu! $1000 a; ( T = set interrupts )
|
88 |
|
|
a: #cpu? $1100 a; ( T = interrupts set? )
|
89 |
|
|
a: #rp@ $1200 a; ( T = r-depth )
|
90 |
|
|
a: #t==0 $1300 a; ( T = t == 0? )
|
91 |
|
|
a: #cpu-id $1400 a; ( T = CPU ID )
|
92 |
|
|
\ a: #alu-lit $1500 a; ( T = instruction, hidden )
|
93 |
|
|
|
94 |
|
|
a: d+1 $0001 or a; ( increment variable stack by one )
|
95 |
|
|
a: d-1 $0003 or a; ( decrement variable stack by one )
|
96 |
|
|
a: d-2 $0002 or a; ( decrement variable stack by two, not used )
|
97 |
|
|
a: r+1 $0004 or a; ( increment variable stack by one )
|
98 |
|
|
a: r-1 $000C or a; ( decrement variable stack by one )
|
99 |
|
|
a: r-2 $0008 or a; ( decrement variable stack by two, not used )
|
100 |
|
|
a: r->pc $0010 or a; ( Set Program Counter to Top of Return Stack )
|
101 |
|
|
a: n->[t] $0020 or a; ( Set Next on Variable Stack to Top on Variable Stack )
|
102 |
|
|
a: t->r $0040 or a; ( Set Top of Return Stack to Top on Variable Stack )
|
103 |
|
|
a: t->n $0080 or a; ( Set Next on Variable Stack to Top on Variable Stack )
|
104 |
|
|
: ?set dup $E000 and abort" argument too large" ; ( u -- )
|
105 |
|
|
a: branch 2/ ?set [a] #branch or t, a; ( a -- : an Unconditional branch )
|
106 |
|
|
a: ?branch 2/ ?set [a] #?branch or t, a; ( a -- : Conditional branch )
|
107 |
|
|
a: call 2/ ?set [a] #call or t, a; ( a -- : Function call )
|
108 |
|
|
a: ALU ?set [a] #alu or a; ( u -- : Make ALU instruction )
|
109 |
|
|
a: alu [a] ALU t, a; ( u -- : ALU operation )
|
110 |
|
|
a: literal ( n -- : compile a number into target )
|
111 |
|
|
dup [a] #literal and if ( numbers above $7FFF take up two instructions )
|
112 |
|
|
invert recurse ( the number is inverted, and 'literal' is called again )
|
113 |
|
|
[a] #~t [a] alu ( then an invert instruction is compiled into the target )
|
114 |
|
|
else
|
115 |
|
|
[a] #literal or t, ( numbers below $8000 are single instructions )
|
116 |
|
|
then a;
|
117 |
|
|
a: return ( -- : Compile a return into the target )
|
118 |
|
|
[a] #t [a] r->pc [a] r-1 [a] alu a;
|
119 |
|
|
: previous there =cell - ; ( -- a )
|
120 |
|
|
: lookback previous t@ ; ( -- u )
|
121 |
|
|
: call? lookback $E000 and [a] #call = ; ( -- t )
|
122 |
|
|
: call>goto previous dup t@ $1FFF and swap t! ; ( -- )
|
123 |
|
|
: fence? fence @ previous u> ; ( -- t )
|
124 |
|
|
: safe? lookback $E000 and [a] #alu = lookback $001C and 0= and ; ( -- t )
|
125 |
|
|
: alu>return previous dup t@ [a] r->pc [a] r-1 swap t! ; ( -- )
|
126 |
|
|
: exit-optimize ( -- )
|
127 |
|
|
fence? if [a] return exit then
|
128 |
|
|
call? if call>goto exit then
|
129 |
|
|
safe? if alu>return exit then
|
130 |
|
|
[a] return ;
|
131 |
|
|
: exit, exit-optimize update-fence ; ( -- )
|
132 |
|
|
: compile-only tlast @ tnfa t@ $20 or tlast @ tnfa t! ; ( -- )
|
133 |
|
|
: immediate tlast @ tnfa t@ $40 or tlast @ tnfa t! ; ( -- )
|
134 |
|
|
: mcreate current @ >r target.1 current ! create r> current ! ;
|
135 |
|
|
: thead ( b u -- : compile word header into target dictionary )
|
136 |
|
|
talign
|
137 |
|
|
there [last] t, tlast !
|
138 |
|
|
there #target + pack$ c@ 1+ aligned tcp +! talign ;
|
139 |
|
|
: lookahead ( -- b u : parse a word, but leave it in the input stream )
|
140 |
|
|
>in @ >r bl parse r> >in ! ;
|
141 |
|
|
: literal [a] literal ; ( u -- )
|
142 |
|
|
: [ ' literal ! ; ( -- )
|
143 |
|
|
: ] ' (literal) ! ; ( -- )
|
144 |
|
|
: h: ( -- : create a word with no name in the target dictionary )
|
145 |
|
|
[compile] [
|
146 |
|
|
$F00D mcreate there , update-fence does> @ [a] call ;
|
147 |
|
|
: t: ( "name", -- : creates a word in the target dictionary )
|
148 |
|
|
lookahead thead h: ;
|
149 |
|
|
: ?unstructured $F00D xor if source type cr 1 abort" unstructured! " then ;
|
150 |
|
|
: fallthrough; [compile] ] ?unstructured ; ( u -- )
|
151 |
|
|
: t; fallthrough; exit, ; \ "[a] return" <- unoptimized version
|
152 |
|
|
: ;; t; ?unstructured ;
|
153 |
|
|
: fetch-xt @ dup 0= abort" (null) " ; ( a -- xt )
|
154 |
|
|
: tconstant ( "name", n --, Run Time: -- )
|
155 |
|
|
>r
|
156 |
|
|
lookahead
|
157 |
|
|
thead
|
158 |
|
|
there tdoConst fetch-xt [a] call r> t, >r
|
159 |
|
|
mcreate r> ,
|
160 |
|
|
does> @ tbody t@ [a] literal ;
|
161 |
|
|
: tvariable ( "name", n -- , Run Time: -- a )
|
162 |
|
|
>r
|
163 |
|
|
lookahead
|
164 |
|
|
thead
|
165 |
|
|
there tdoVar fetch-xt [a] call r> t, >r
|
166 |
|
|
mcreate r> ,
|
167 |
|
|
does> @ tbody [a] literal ;
|
168 |
|
|
: tlocation ( "name", n -- : Reserve space in target for a memory location )
|
169 |
|
|
there swap t, mcreate , does> @ [a] literal ;
|
170 |
|
|
: [t] ( "name", -- a : get the address of a target word )
|
171 |
|
|
bl word target.1 search-wordlist 0= abort" [t]?"
|
172 |
|
|
cfa >body @ ;
|
173 |
|
|
: [f] ( "name", -- execute word in host Forth vocabulary )
|
174 |
|
|
bl word forth-wordlist search-wordlist 0= abort" [f]?"
|
175 |
|
|
cfa execute ;
|
176 |
|
|
: [v] [t] =cell + ; ( "name", -- a )
|
177 |
|
|
: xchange ( "name1", "name2", -- : exchange target vocabularies )
|
178 |
|
|
[last] [t] t! [t] t@ tlast meta! ;
|
179 |
|
|
: begin there update-fence ; ( -- a )
|
180 |
|
|
: until [a] ?branch ; ( a -- )
|
181 |
|
|
: if there update-fence 0 [a] ?branch ; ( -- a )
|
182 |
|
|
: skip there update-fence 0 [a] branch ; ( -- a )
|
183 |
|
|
: then begin 2/ over t@ or swap t! ; ( a -- )
|
184 |
|
|
: else skip swap then ; ( a -- a )
|
185 |
|
|
: while if swap ; ( a -- a a )
|
186 |
|
|
: repeat [a] branch then update-fence ; ( a -- )
|
187 |
|
|
: again [a] branch update-fence ; ( a -- )
|
188 |
|
|
: aft drop skip begin swap ; ( a -- a )
|
189 |
|
|
: constant mcreate , does> @ literal ; ( "name", a -- )
|
190 |
|
|
: [char] char literal ; ( "name" )
|
191 |
|
|
: postpone [t] [a] call ; ( "name", -- )
|
192 |
|
|
: next tdoNext fetch-xt [a] call t, update-fence ; ( a -- )
|
193 |
|
|
: exit exit, ; ( -- )
|
194 |
|
|
: ' [t] literal ; ( "name", -- )
|
195 |
|
|
: recurse tlast @ tcfa [a] call ; ( -- )
|
196 |
|
|
: ." tdoPrintString fetch-xt [a] call $literal ; ( "string", -- )
|
197 |
|
|
: $" tdoStringLit fetch-xt [a] call $literal ; ( "string", -- )
|
198 |
|
|
: nop ]asm #t alu asm[ ;
|
199 |
|
|
: dup ]asm #t t->n d+1 alu asm[ ;
|
200 |
|
|
: over ]asm #n t->n d+1 alu asm[ ;
|
201 |
|
|
: invert ]asm #~t alu asm[ ;
|
202 |
|
|
: + ]asm #t+n d-1 alu asm[ ;
|
203 |
|
|
: swap ]asm #n t->n alu asm[ ;
|
204 |
|
|
: nip ]asm #t d-1 alu asm[ ;
|
205 |
|
|
: drop ]asm #n d-1 alu asm[ ;
|
206 |
|
|
: >r ]asm #n t->r r+1 d-1 alu asm[ ;
|
207 |
|
|
: r> ]asm #r t->n r-1 d+1 alu asm[ ;
|
208 |
|
|
: r@ ]asm #r t->n d+1 alu asm[ ;
|
209 |
|
|
: @ ]asm #[t] alu asm[ ;
|
210 |
|
|
: rshift ]asm #n>>t d-1 alu asm[ ;
|
211 |
|
|
: lshift ]asm #n<
|
212 |
|
|
: = ]asm #t==n d-1 alu asm[ ;
|
213 |
|
|
: u< ]asm #nu
|
214 |
|
|
: < ]asm #n
|
215 |
|
|
: and ]asm #t&n d-1 alu asm[ ;
|
216 |
|
|
: xor ]asm #t^n d-1 alu asm[ ;
|
217 |
|
|
: or ]asm #t|n d-1 alu asm[ ;
|
218 |
|
|
: sp@ ]asm #sp@ t->n d+1 alu asm[ ;
|
219 |
|
|
: 1- ]asm #t-1 alu asm[ ;
|
220 |
|
|
: rp@ ]asm #rp@ t->n d+1 alu asm[ ;
|
221 |
|
|
: 0= ]asm #t==0 alu asm[ ;
|
222 |
|
|
: rdrop ]asm #t r-1 alu asm[ ;
|
223 |
|
|
\ : 2rdrop ]asm #t r-2 alu asm[ ;
|
224 |
|
|
\ : rdrop>r ]asm #n t->r d-1 alu asm[ ;
|
225 |
|
|
: dup>r ]asm #t t->r r+1 alu asm[ ;
|
226 |
|
|
: over-and ]asm #t&n alu asm[ ;
|
227 |
|
|
: over+ ]asm #t+n alu asm[ ;
|
228 |
|
|
\ : over-xor ]asm #t^n alu asm[ ;
|
229 |
|
|
: >r-dup ]asm #n t->r r+1 alu asm[ ;
|
230 |
|
|
: 2dup= ]asm #t==n t->n d+1 alu asm[ ;
|
231 |
|
|
: 2dup< ]asm #nn d+1 alu asm[ ;
|
232 |
|
|
: 2dupu< ]asm #nun d+1 alu asm[ ;
|
233 |
|
|
: 2dup-xor ]asm #t^n t->n d+1 alu asm[ ;
|
234 |
|
|
: store ]asm #n n->[t] d-1 alu asm[ ;
|
235 |
|
|
: tuck! ]asm #t n->[t] d-1 alu asm[ ;
|
236 |
|
|
: cpu-id ]asm #cpu-id d+1 alu asm[ ;
|
237 |
|
|
: cpu! ]asm #cpu! d-1 alu asm[ ;
|
238 |
|
|
: cpu? ]asm #cpu? t->n d+1 alu asm[ ;
|
239 |
|
|
: dup@ ]asm #[t] t->n d+1 alu asm[ ;
|
240 |
|
|
: r>rdrop ]asm #r t->n r-2 d+1 alu asm[ ;
|
241 |
|
|
: rxchg ]asm #r t->r alu asm[ ;
|
242 |
|
|
: nip-nip ]asm #t d-2 alu asm[ ;
|
243 |
|
|
: for >r begin ;
|
244 |
|
|
: meta: : ;
|
245 |
|
|
( : :noname h: ; )
|
246 |
|
|
: : t: ;
|
247 |
|
|
meta: ; t; ;
|
248 |
|
|
hide meta:
|
249 |
|
|
hide t:
|
250 |
|
|
hide t;
|
251 |
|
|
]asm #~t ALU asm[ constant =invert ( invert instruction )
|
252 |
|
|
]asm #t r->pc r-1 ALU asm[ constant =exit ( return/exit instruction )
|
253 |
|
|
]asm #n t->r d-1 r+1 ALU asm[ constant =>r ( to r. stk. instruction )
|
254 |
|
|
$20 constant =bl ( blank, or space )
|
255 |
|
|
$D constant =cr ( carriage return )
|
256 |
|
|
$A constant =lf ( line feed )
|
257 |
|
|
$8 constant =bs ( back space )
|
258 |
|
|
$7F constant =del ( delete key )
|
259 |
|
|
\ $1B constant =escape ( escape character )
|
260 |
|
|
$50 constant tib-length ( size of terminal input buffer )
|
261 |
|
|
$40 constant word-length ( maximum length of a word )
|
262 |
|
|
$40 constant c/l ( characters per line in a block )
|
263 |
|
|
$10 constant l/b ( lines in a block )
|
264 |
|
|
$2BAD constant magic ( magic number for compiler security )
|
265 |
|
|
( Volatile variables )
|
266 |
|
|
$3B02 constant last-def ( last, possibly unlinked, word definition )
|
267 |
|
|
$3B06 constant id ( used for source id )
|
268 |
|
|
$3B0A constant handler ( current handler for throw/catch )
|
269 |
|
|
$3B0C constant block-dirty ( -1 if loaded block buffer is modified )
|
270 |
|
|
$3B14 constant ( "accept" vector )
|
271 |
|
|
$3B16 constant ( "tap" vector, for terminal handling )
|
272 |
|
|
$3B18 constant ( c -- : emit character )
|
273 |
|
|
$3B1A constant context ( holds current context for search order )
|
274 |
|
|
( area for context is #vocs large )
|
275 |
|
|
$3B2A constant #tib ( Current count of terminal input buffer )
|
276 |
|
|
$3B2C constant tib-buf ( ... and address )
|
277 |
|
|
$3B2E constant tib-start ( backup tib-buf value )
|
278 |
|
|
$3C00 constant block-buffer ( block buffer is stored here )
|
279 |
|
|
|
280 |
|
|
$10 constant header-length ( location of length in header )
|
281 |
|
|
$12 constant header-crc ( location of CRC in header )
|
282 |
|
|
$14 constant header-options ( location of options bits in header )
|
283 |
|
|
target.1 +order ( Add target word dictionary to search order )
|
284 |
|
|
meta -order meta +order ( Reorder so *meta* has a higher priority )
|
285 |
|
|
system -order ( Remove system vocabulary to previously accidents )
|
286 |
|
|
forth-wordlist -order ( Remove normal Forth words to prevent accidents )
|
287 |
|
|
|
288 |
|
|
\ ============================================================================
|
289 |
|
|
\ # Start of Image
|
290 |
|
|
|
291 |
|
|
|
292 |
|
|
|
293 |
|
|
|
294 |
|
|
|
295 |
|
|
|
296 |
|
|
|
297 |
|
|
|
298 |
|
|
|
299 |
|
|
|
300 |
|
|
|
301 |
|
|
|
302 |
|
|
|
303 |
|
|
$0001 t, \ $14: Header options
|
304 |
|
|
h: doVar r> ; ( -- a : push return address and exit to caller )
|
305 |
|
|
h: doConst r> @ ; ( -- u : push value at return address and exit to caller )
|
306 |
|
|
[t] doVar tdoVar meta!
|
307 |
|
|
[t] doConst tdoConst meta!
|
308 |
|
|
|
309 |
|
|
|
310 |
|
|
pad-area tconstant pad ( pad variable - offset into temporary storage )
|
311 |
|
|
$8 constant #vocs ( number of vocabularies in allowed )
|
312 |
|
|
$2 tconstant cell ( size of a cell in bytes )
|
313 |
|
|
$400 tconstant b/buf ( size of a block )
|
314 |
|
|
|
315 |
|
|
|
316 |
|
|
|
317 |
|
|
|
318 |
|
|
$0 tvariable >in ( Hold character pointer when parsing input )
|
319 |
|
|
1 tlocation seed1 ( PRNG seed; never set to zero )
|
320 |
|
|
1 tlocation seed2 ( PRNG seed; never set to zero )
|
321 |
|
|
$0 tvariable state ( compiler state variable )
|
322 |
|
|
$0 tvariable hld ( Pointer into hold area for numeric output )
|
323 |
|
|
$A tvariable base ( Current output radix )
|
324 |
|
|
$0 tvariable span ( Hold character count received by expect )
|
325 |
|
|
|
326 |
|
|
$FFFF tvariable dpl ( number of places after fraction )
|
327 |
|
|
|
328 |
|
|
xchange _forth-wordlist _system
|
329 |
|
|
|
330 |
|
|
|
331 |
|
|
|
332 |
|
|
|
333 |
|
|
|
334 |
|
|
|
335 |
|
|
( : nop nop ; ( -- : do nothing )
|
336 |
|
|
: cpu-id cpu-id ; ( -- u : returns CPU ID )
|
337 |
|
|
: cpu? cpu? ; ( -- u : returns CPU status )
|
338 |
|
|
: cpu! cpu! ; ( u -- : sets CPU status )
|
339 |
|
|
xchange _system _forth-wordlist
|
340 |
|
|
: dup dup ; ( n -- n n : duplicate value on top of stack )
|
341 |
|
|
: over over ; ( n1 n2 -- n1 n2 n1 : duplicate second value on stack )
|
342 |
|
|
: invert invert ; ( u -- u : bitwise invert of value on top of stack )
|
343 |
|
|
: + + ; ( u u -- u : addition without carry )
|
344 |
|
|
: swap swap ; ( n1 n2 -- n2 n1 : swap two values on stack )
|
345 |
|
|
: nip nip ; ( n1 n2 -- n2 : remove second item on stack )
|
346 |
|
|
: drop drop ; ( n -- : remove item on stack )
|
347 |
|
|
: @ @ ; ( a -- u : load value at address )
|
348 |
|
|
: ! store drop ; ( u a -- : store *u* at address *a* )
|
349 |
|
|
: rshift rshift ; ( u1 u2 -- u : shift u2 by u1 places to the right )
|
350 |
|
|
: lshift lshift ; ( u1 u2 -- u : shift u2 by u1 places to the left )
|
351 |
|
|
: = = ; ( u1 u2 -- t : does u2 equal u1? )
|
352 |
|
|
: u< u< ; ( u1 u2 -- t : is u2 less than u1 )
|
353 |
|
|
: < < ; ( u1 u2 -- t : is u2 less than u1, signed version )
|
354 |
|
|
: and and ; ( u u -- u : bitwise and )
|
355 |
|
|
: xor xor ; ( u u -- u : bitwise exclusive or )
|
356 |
|
|
: or or ; ( u u -- u : bitwise or )
|
357 |
|
|
: 1- 1- ; ( u -- u : decrement top of stack )
|
358 |
|
|
: 0= 0= ; ( u -- t : if top of stack equal to zero )
|
359 |
|
|
: sp@ sp@ ; ( -- u : stack position [equivalent to depth] )
|
360 |
|
|
there constant inline-start
|
361 |
|
|
( : rp@ rp@ fallthrough; compile-only ( -- u )
|
362 |
|
|
: exit exit fallthrough; compile-only ( -- )
|
363 |
|
|
: >r >r fallthrough; compile-only ( u --, R: -- u )
|
364 |
|
|
: r> r> fallthrough; compile-only ( -- u, R: u -- )
|
365 |
|
|
: r@ r@ fallthrough; compile-only ( -- u )
|
366 |
|
|
: rdrop rdrop fallthrough; compile-only ( --, R: u -- )
|
367 |
|
|
there constant inline-end
|
368 |
|
|
|
369 |
|
|
\ ============================================================================
|
370 |
|
|
\ # Core Words
|
371 |
|
|
|
372 |
|
|
( 0 tvariable hidden ( vocabulary for hidden words )
|
373 |
|
|
h: [-1] -1 ; ( -- -1 : space saving measure, push -1 )
|
374 |
|
|
h: 0x8000 $8000 ; ( -- $8000 : space saving measure, push $8000 )
|
375 |
|
|
h: 2drop-0 drop fallthrough; ( n n -- 0 )
|
376 |
|
|
h: drop-0 drop fallthrough; ( n -- 0 )
|
377 |
|
|
h: 0x0000 $0000 ; ( -- $0000 : space/optimization, push $0000 )
|
378 |
|
|
h: state@ state @ ; ( -- u )
|
379 |
|
|
h: first-bit 1 and ; ( u -- u )
|
380 |
|
|
h: in@ >in @ ; ( -- u )
|
381 |
|
|
h: base@ base @ ; ( -- u )
|
382 |
|
|
h: hld@ hld @ ; ( -- u )
|
383 |
|
|
h: blk-@ blk @ ;
|
384 |
|
|
|
385 |
|
|
h: ?exit if rdrop exit then ; ( u --, R: xt -- xt| : conditional return )
|
386 |
|
|
: 2drop drop drop ; ( n n -- )
|
387 |
|
|
: 1+ 1 + ; ( n -- n : increment a value )
|
388 |
|
|
: negate 1- invert ; ( n -- n : negate a number )
|
389 |
|
|
: - negate + ; ( n1 n2 -- n : subtract n1 from n2 )
|
390 |
|
|
h: over- over - ; ( u u -- u u )
|
391 |
|
|
: aligned dup first-bit + ; ( b -- a )
|
392 |
|
|
h: cell- cell - ; ( a -- a : adjust address to previous cell )
|
393 |
|
|
: cell+ cell + ; ( a -- a : move address forward to next cell )
|
394 |
|
|
: cells 1 lshift ; ( n -- n : convert cells count to address count )
|
395 |
|
|
: chars 1 rshift ; ( n -- n : convert bytes to number of cells )
|
396 |
|
|
: ?dup dup if dup exit then ; ( n -- 0 | n n : duplicate non zero value )
|
397 |
|
|
: > swap < ; ( n1 n2 -- t : signed greater than, n1 > n2 )
|
398 |
|
|
: u> swap u< ; ( u1 u2 -- t : unsigned greater than, u1 > u2 )
|
399 |
|
|
: <> = invert ; ( n n -- t : not equal )
|
400 |
|
|
: 0<> 0= invert ; ( n n -- t : not equal to zero )
|
401 |
|
|
: 0> 0 > ; ( n -- t : greater than zero? )
|
402 |
|
|
: 0< 0 < ; ( n -- t : less than zero? )
|
403 |
|
|
: 2dup over over ; ( n1 n2 -- n1 n2 n1 n2 )
|
404 |
|
|
: tuck swap over ; ( n1 n2 -- n2 n1 n2 )
|
405 |
|
|
: +! tuck @ + fallthrough; ( n a -- : increment value at *a* by *n* )
|
406 |
|
|
h: swap! swap ! ; ( a u -- )
|
407 |
|
|
h: zero 0 swap! ; ( a -- : zero value at address )
|
408 |
|
|
: 1+! 1 h: s+! swap +! ;; ( a -- : increment value at address by 1 )
|
409 |
|
|
: 1-! [-1] s+! ; ( a -- : decrement value at address by 1 )
|
410 |
|
|
: 2! ( d a -- ) tuck! cell+ ! ; ( n n a -- )
|
411 |
|
|
: 2@ ( a -- d ) dup cell+ @ swap @ ; ( a -- n n )
|
412 |
|
|
h: get-current current @ ; ( -- wid )
|
413 |
|
|
: bl =bl ; ( -- c )
|
414 |
|
|
: within over- >r - r> u< ; ( u lo hi -- t )
|
415 |
|
|
h: s>d dup 0< ; ( n -- d )
|
416 |
|
|
: abs s>d if negate exit then ; ( n -- u )
|
417 |
|
|
: source #tib 2@ ; ( -- a u )
|
418 |
|
|
h: tib source drop ; ( -- a )
|
419 |
|
|
: source-id id @ ; ( -- 0 | -1 )
|
420 |
|
|
: rot >r swap r> swap ; ( n1 n2 n3 -- n2 n3 n1 )
|
421 |
|
|
: -rot rot rot ; ( n1 n2 n3 -- n3 n1 n2 )
|
422 |
|
|
h: rot-drop rot drop ; ( n1 n2 n3 -- n2 n3 )
|
423 |
|
|
h: d0= or 0= ; ( d -- t )
|
424 |
|
|
( : 2swap >r -rot r> -rot ; ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
|
425 |
|
|
( : d< rot )
|
426 |
|
|
( 2dup )
|
427 |
|
|
( > if = nip-nip if 0 exit then [-1] exit then 2drop u< ; ( d -- f )
|
428 |
|
|
( : d> 2swap d< ; ( d -- t )
|
429 |
|
|
( : du> 2swap du< ; ( d -- t )
|
430 |
|
|
( : d= rot = -rot = and ; ( d d -- t )
|
431 |
|
|
( : d- dnegate d+ ; ( d d -- d )
|
432 |
|
|
( : dabs s>d if dnegate exit then ; ( d -- ud )
|
433 |
|
|
( : even first-bit 0= ; ( u -- t )
|
434 |
|
|
( : odd even 0= ; ( u -- t )
|
435 |
|
|
( : pow2? dup dup 1- and 0= and ; ( u -- u|0 : is u a power of 2? )
|
436 |
|
|
( : opposite? xor 0< ; ( n n -- f : true if opposite signs )
|
437 |
|
|
: execute >r ; ( cfa -- : execute a function )
|
438 |
|
|
h: @execute @ ?dup if execute exit then ; ( cfa -- )
|
439 |
|
|
: c@ dup@ swap first-bit 3 lshift rshift h: lsb $FF and ;; ( b--c: char load )
|
440 |
|
|
: c! ( c b -- : store character at address )
|
441 |
|
|
tuck first-bit 3 lshift dup>r swap lsb swap
|
442 |
|
|
lshift over @
|
443 |
|
|
$FF r> 8 xor lshift and or swap! ;
|
444 |
|
|
: here cp @ ; ( -- a )
|
445 |
|
|
: align here fallthrough; ( -- )
|
446 |
|
|
h: cp! aligned cp ! ; ( n -- )
|
447 |
|
|
: allot cp +! ; ( n -- )
|
448 |
|
|
h: 2>r rxchg swap >r >r ; ( u1 u2 --, R: -- u1 u2 )
|
449 |
|
|
h: 2r> r> r> swap rxchg nop ; ( -- u1 u2, R: u1 u2 -- )
|
450 |
|
|
h: doNext 2r> ?dup if 1- >r @ >r exit then cell+ >r ;
|
451 |
|
|
[t] doNext tdoNext meta!
|
452 |
|
|
: min 2dup< fallthrough; ( n n -- n )
|
453 |
|
|
h: mux if drop exit then nip ; ( n1 n2 b -- n : multiplex operation )
|
454 |
|
|
: max 2dup > mux ; ( n n -- n )
|
455 |
|
|
( : 2over 2>r 2dup 2r> 2swap ; )
|
456 |
|
|
( : 2nip 2>r 2drop 2r> nop ; )
|
457 |
|
|
( : 4dup 2over 2over ; )
|
458 |
|
|
( : dmin 4dup d< if 2drop exit else 2nip ; )
|
459 |
|
|
( : dmax 4dup d> if 2drop exit else 2nip ; )
|
460 |
|
|
\ : um+ ( w w -- w carry )
|
461 |
|
|
\ over over+ >r
|
462 |
|
|
\ r@ 0 < invert >r
|
463 |
|
|
\ over over-and
|
464 |
|
|
\ 0 < r> or >r
|
465 |
|
|
\ or 0 < r> and 1- invert
|
466 |
|
|
\ r> swap ;
|
467 |
|
|
\ h: upivot ( u1 u2 -- min max ) 2dupu< if exit then swap ;
|
468 |
|
|
: um+ 2dupu< 0= if swap then over+ swap over swap u< 1 and ; ( u u -- u carry )
|
469 |
|
|
|
470 |
|
|
h: dnegate invert >r invert 1 um+ r> + ; ( d -- d )
|
471 |
|
|
h: d+ >r swap >r um+ r> + r> + ; ( d d -- d )
|
472 |
|
|
: um* ( u u -- ud )
|
473 |
|
|
|
474 |
|
|
for dup um+ >r >r-dup um+ r> + r>
|
475 |
|
|
if >r over um+ r> + then
|
476 |
|
|
next rot drop ;
|
477 |
|
|
: * um* drop ; ( n n -- n )
|
478 |
|
|
h: rp! ( n -- , R: ??? -- ??? : set the return stack pointer )
|
479 |
|
|
r> swap begin dup rp@ = 0= while rdrop repeat drop >r ;
|
480 |
|
|
: key? @execute ; ( -- c -1 | 0 )
|
481 |
|
|
: key begin key? until ; ( -- c )
|
482 |
|
|
: /string over min rot over+ -rot - ; ( b u1 u2 -- b u : advance string u2 )
|
483 |
|
|
h: +string 1 /string ; ( b u -- b u : )
|
484 |
|
|
: count dup 1+ swap c@ ; ( b -- b u )
|
485 |
|
|
h: string@ over c@ ; ( b u -- b u c )
|
486 |
|
|
xchange _forth-wordlist _system
|
487 |
|
|
h: lshift-xor lshift xor ;
|
488 |
|
|
h: rshift-xor rshift xor ;
|
489 |
|
|
: crc ( b u -- u : calculate ccitt-ffff CRC )
|
490 |
|
|
[-1] ( -1 = 0xffff ) >r
|
491 |
|
|
begin
|
492 |
|
|
?dup
|
493 |
|
|
while
|
494 |
|
|
string@ r> swap
|
495 |
|
|
( CCITT polynomial $1021, or "x16 + x12 + x5 + 1" )
|
496 |
|
|
over $8 rshift-xor ( crc x )
|
497 |
|
|
dup $4 rshift-xor ( crc x )
|
498 |
|
|
dup $5 lshift-xor ( crc x )
|
499 |
|
|
dup $C lshift-xor ( crc x )
|
500 |
|
|
swap $8 lshift-xor ( crc )
|
501 |
|
|
>r +string
|
502 |
|
|
repeat r> nip ;
|
503 |
|
|
xchange _system _forth-wordlist
|
504 |
|
|
h: last get-current @ ; ( -- pwd )
|
505 |
|
|
h: echo @execute ; ( c -- )
|
506 |
|
|
: emit @execute ; ( c -- : write out a char )
|
507 |
|
|
: cr =cr emit =lf emit ; ( -- : emit a newline )
|
508 |
|
|
: space 1 fallthrough; ( -- : emit a space )
|
509 |
|
|
h: spaces =bl fallthrough; ( +n -- )
|
510 |
|
|
h: nchars ( +n c -- : emit c n times )
|
511 |
|
|
swap 0 max for aft dup emit then next drop ;
|
512 |
|
|
h: colon-space [char] : emit space ; ( -- )
|
513 |
|
|
\ This version of pick mashes the return stack for large pick depths, an
|
514 |
|
|
\ alternative would be to move non-destructively up and down the stack with
|
515 |
|
|
\ special instructions.
|
516 |
|
|
( vn...v0 u -- vn...v0 vu )
|
517 |
|
|
: pick ?dup if swap >r 1- pick r> swap exit then dup ;
|
518 |
|
|
h: ndrop for aft drop then next ;
|
519 |
|
|
h: >char dup $7F =bl within if drop [char] _ then ; ( c -- c )
|
520 |
|
|
: type 0 fallthrough; ( b u -- )
|
521 |
|
|
h: typist ( b u f -- : print a string )
|
522 |
|
|
>r begin dup while
|
523 |
|
|
swap count r@
|
524 |
|
|
if
|
525 |
|
|
>char
|
526 |
|
|
then
|
527 |
|
|
emit
|
528 |
|
|
swap 1-
|
529 |
|
|
repeat
|
530 |
|
|
rdrop 2drop ;
|
531 |
|
|
h: $type [-1] typist ; ( b u -- )
|
532 |
|
|
: cmove for aft >r-dup c@ r@ c! 1+ r> 1+ then next 2drop ; ( b b u -- )
|
533 |
|
|
: fill swap for swap aft 2dup c! 1+ then next 2drop ; ( b u c -- )
|
534 |
|
|
|
535 |
|
|
: catch ( xt -- exception# | 0 : return addr on stack )
|
536 |
|
|
sp@ >r ( xt : save data stack depth )
|
537 |
|
|
handler @ >r ( xt : and previous handler )
|
538 |
|
|
rp@ handler ! ( xt : set current handler )
|
539 |
|
|
execute ( execute returns if no throw )
|
540 |
|
|
r> handler ! ( restore previous handler )
|
541 |
|
|
rdrop ( discard saved stack ptr )
|
542 |
|
|
0x0000 ; ( 0 : normal completion )
|
543 |
|
|
|
544 |
|
|
: throw ( ??? exception# -- ??? exception# )
|
545 |
|
|
?dup if ( exc# \ 0 throw is no-op )
|
546 |
|
|
handler @ rp! ( exc# : restore prev return stack )
|
547 |
|
|
r> handler ! ( exc# : restore prev handler )
|
548 |
|
|
rxchg ( saved-sp : exc# on return stack )
|
549 |
|
|
sp@ swap - ndrop r> ( exc# : restore stack )
|
550 |
|
|
( return to the caller of catch because return )
|
551 |
|
|
( stack is restored to the state that existed )
|
552 |
|
|
( when catch began execution )
|
553 |
|
|
then ;
|
554 |
|
|
h: -throw negate throw ; ( u -- : negate and throw )
|
555 |
|
|
[t] -throw 2/ 4 tcells t!
|
556 |
|
|
: um/mod ( ud u -- ur uq )
|
557 |
|
|
?dup 0= if $A -throw exit then
|
558 |
|
|
2dupu<
|
559 |
|
|
if negate $F
|
560 |
|
|
for >r-dup um+ >r >r-dup um+ r> + dup
|
561 |
|
|
r> r@ swap >r um+ r> or
|
562 |
|
|
if >r drop 1 + r> else drop then r>
|
563 |
|
|
next
|
564 |
|
|
drop swap exit
|
565 |
|
|
then 2drop drop [-1] dup ;
|
566 |
|
|
: m/mod ( d n -- r q ) \ floored division
|
567 |
|
|
dup 0< dup>r
|
568 |
|
|
if
|
569 |
|
|
negate >r dnegate r>
|
570 |
|
|
then
|
571 |
|
|
>r-dup 0< if r@ + then r> um/mod r>
|
572 |
|
|
if swap negate swap exit then ;
|
573 |
|
|
\ : */ >r um* r> m/mod nip ; ( n n n -- )
|
574 |
|
|
: /mod over 0< swap m/mod ; ( n n -- r q )
|
575 |
|
|
: mod /mod drop ; ( n n -- r )
|
576 |
|
|
: / /mod nip ; ( n n -- q )
|
577 |
|
|
h: 1depth 1 fallthrough; ( ??? -- : check depth is at least one )
|
578 |
|
|
h: ?depth dup 0= if drop exit then sp@ 1- u> if 4 -throw exit then ; ( u -- )
|
579 |
|
|
: decimal $A fallthrough; ( -- : set base to decimal )
|
580 |
|
|
h: base! base ! ; ( u -- : set base )
|
581 |
|
|
: hex $10 base! ; ( -- )
|
582 |
|
|
\ h: radix base@ dup 2 - $23 u< ?exit decimal $28 -throw ; ( -- u )
|
583 |
|
|
: hold hld@ 1- dup hld ! c! hld@ pad $80 - u> ?exit $11 -throw ; ( c -- )
|
584 |
|
|
h: extract dup>r um/mod rxchg um/mod r> rot ; ( ud ud -- ud u )
|
585 |
|
|
h: digit 9 over < 7 and + [char] 0 + ; ( u -- c )
|
586 |
|
|
: #> 2drop hld@ pad over- ; ( w -- b u )
|
587 |
|
|
: # 2 ?depth 0 base@ extract digit hold ; ( d -- d )
|
588 |
|
|
: #s begin # 2dup d0= until ; ( d -- 0 )
|
589 |
|
|
: <# pad hld ! ; ( -- )
|
590 |
|
|
: sign 0< 0= ?exit [char] - hold ; ( n -- )
|
591 |
|
|
h: (.) ( n -- b u : convert a signed integer to a numeric string )
|
592 |
|
|
dup>r abs 0 <# #s r> sign #> ;
|
593 |
|
|
h: (u.) 0 <# #s #> ; ( u -- b u : turn *u* into number string )
|
594 |
|
|
: u.r >r (u.) r> fallthrough; ( u +n -- : print u right justified by +n)
|
595 |
|
|
h: adjust over- spaces type ; ( b n n -- )
|
596 |
|
|
h: d5u.r dup fallthrough; ( u -- u )
|
597 |
|
|
h: 5u.r space 5 u.r space ; ( u -- )
|
598 |
|
|
( : .r >r (.)( r> adjust ; ( n n -- : print n, right justified by +n )
|
599 |
|
|
: u. (u.) h: blt space type ;; ( u -- : print unsigned number )
|
600 |
|
|
: . (.) blt ; ( n -- print number )
|
601 |
|
|
( : >base swap base @ >r base ! execute r> base ! ; )
|
602 |
|
|
( : d. $a ' . >base ; )
|
603 |
|
|
( : h. $10 ' u. >base ; )
|
604 |
|
|
h: adown cell negate and ; ( a -- a : align down )
|
605 |
|
|
xchange _forth-wordlist _system
|
606 |
|
|
: pack$ ( b u a -- a ) \ null fill
|
607 |
|
|
aligned dup>r over
|
608 |
|
|
dup adown
|
609 |
|
|
- over+ zero 2dup c! 1+ swap ( 2dup 0 fill ) cmove r> ;
|
610 |
|
|
xchange _system _forth-wordlist
|
611 |
|
|
: compare ( a1 u1 a2 u2 -- n : string equality )
|
612 |
|
|
rot
|
613 |
|
|
over- ?dup if >r 2drop r> nip exit then
|
614 |
|
|
for ( a1 a2 )
|
615 |
|
|
aft
|
616 |
|
|
count rot count rot - ?dup
|
617 |
|
|
if rdrop nip-nip exit then
|
618 |
|
|
then
|
619 |
|
|
next 2drop-0 ;
|
620 |
|
|
h: ^h ( bot eot cur -- bot eot cur )
|
621 |
|
|
>r over r@ < dup
|
622 |
|
|
if
|
623 |
|
|
=bs dup echo =bl echo echo
|
624 |
|
|
then r> + ;
|
625 |
|
|
h: tap dup echo over c! 1+ ; ( bot eot cur c -- bot eot cur )
|
626 |
|
|
h: delete? dup =bs = swap =del = or 0= ; ( c -- t : delete key pressed? )
|
627 |
|
|
h: ktap ( bot eot cur c -- bot eot cur )
|
628 |
|
|
dup =cr xor
|
629 |
|
|
if delete? \ =bs xor
|
630 |
|
|
if =bl tap exit then ^h exit
|
631 |
|
|
then drop nip dup ;
|
632 |
|
|
\ h: ktap? dup =bl - $5F u< swap =del xor and ; ( c -- t : possible ktap? )
|
633 |
|
|
: accept ( b u -- b u )
|
634 |
|
|
over+ over
|
635 |
|
|
begin
|
636 |
|
|
2dup-xor
|
637 |
|
|
while
|
638 |
|
|
key dup =bl - $5F u< if tap else @execute then
|
639 |
|
|
repeat drop over- ;
|
640 |
|
|
: expect @execute span ! drop ; ( b u -- )
|
641 |
|
|
: query tib tib-length @execute #tib ! drop-0 fallthrough;
|
642 |
|
|
h: in! >in ! ; ( u -- )
|
643 |
|
|
h: word.count count fallthrough; ( nfa -- u : get a words length )
|
644 |
|
|
h: word.length $1F and ;
|
645 |
|
|
xchange _forth-wordlist _system
|
646 |
|
|
: nfa cell+ ; ( pwd -- nfa : move to name field address)
|
647 |
|
|
: cfa nfa dup c@ word.length + cell+ adown ; ( pwd -- cfa )
|
648 |
|
|
xchange _system _forth-wordlist
|
649 |
|
|
h: .id nfa word.count type space ; ( pwd -- : print out a word )
|
650 |
|
|
h: immediate? nfa $40 fallthrough; ( pwd -- t : is word immediate? )
|
651 |
|
|
h: set? swap @ and 0<> ; ( a u -- t : is any of 'u' set? )
|
652 |
|
|
h: compile-only? nfa $20 set? ; ( pwd -- t : is word compile only? )
|
653 |
|
|
h: inline? inline-start inline-end within ; ( pwd -- t : is word inline? )
|
654 |
|
|
h: (search-wordlist) ( a wid -- PWD PWD 1|PWD PWD -1|0 a 0: find word in WID )
|
655 |
|
|
swap >r-dup
|
656 |
|
|
begin
|
657 |
|
|
dup
|
658 |
|
|
while
|
659 |
|
|
dup nfa count $9F ( $1F:word-length + $80:hidden ) and r@ count compare 0=
|
660 |
|
|
if ( found! )
|
661 |
|
|
rdrop
|
662 |
|
|
dup immediate? 1 or negate exit
|
663 |
|
|
then
|
664 |
|
|
nip dup@
|
665 |
|
|
repeat
|
666 |
|
|
rdrop 2drop-0 ;
|
667 |
|
|
h: (find) ( a -- pwd pwd 1 | pwd pwd -1 | 0 a 0 : find a word dictionary )
|
668 |
|
|
>r
|
669 |
|
|
context
|
670 |
|
|
begin
|
671 |
|
|
dup@
|
672 |
|
|
while
|
673 |
|
|
dup@ @ r@ swap (search-wordlist) ?dup
|
674 |
|
|
if
|
675 |
|
|
>r rot-drop r>rdrop exit
|
676 |
|
|
then
|
677 |
|
|
cell+
|
678 |
|
|
repeat drop-0 r> 0x0000 ;
|
679 |
|
|
: search-wordlist (search-wordlist) rot-drop ; ( a wid -- PWD 1|PWD -1|a 0 )
|
680 |
|
|
: find ( a -- pwd 1 | pwd -1 | a 0 : find a word in the dictionary )
|
681 |
|
|
(find) rot-drop ;
|
682 |
|
|
h: digit? ( c base -- u f )
|
683 |
|
|
>r [char] 0 - 9 over <
|
684 |
|
|
if
|
685 |
|
|
7 -
|
686 |
|
|
dup $A < or
|
687 |
|
|
then dup r> u< ;
|
688 |
|
|
: >number ( ud b u -- ud b u : convert string to number )
|
689 |
|
|
begin
|
690 |
|
|
( get next character )
|
691 |
|
|
2dup 2>r drop c@ base@ digit?
|
692 |
|
|
0= if ( d char )
|
693 |
|
|
drop ( d char -- d )
|
694 |
|
|
2r> ( restore string )
|
695 |
|
|
nop exit ( ..exit )
|
696 |
|
|
then ( d char )
|
697 |
|
|
swap base@ um* drop rot base@ um* d+ ( accumulate digit )
|
698 |
|
|
2r> ( restore string )
|
699 |
|
|
+string dup 0= ( advance string and test for end )
|
700 |
|
|
until ;
|
701 |
|
|
h: number? ( a u -- d -1 | a u 0 )
|
702 |
|
|
[-1] dpl !
|
703 |
|
|
base@ >r
|
704 |
|
|
string@ [char] - = dup>r if +string then
|
705 |
|
|
string@ [char] $ = if hex +string then
|
706 |
|
|
2>r 0 dup 2r>
|
707 |
|
|
begin
|
708 |
|
|
>number dup
|
709 |
|
|
while string@ [char] . ( fsp @ ) xor
|
710 |
|
|
if rot-drop rot r> 2drop-0 r> base! exit then
|
711 |
|
|
1- dpl ! 1+ dpl @
|
712 |
|
|
repeat 2drop r> if dnegate then r> base! [-1] ;
|
713 |
|
|
h: -trailing ( b u -- b u : remove trailing spaces )
|
714 |
|
|
for
|
715 |
|
|
aft =bl over r@ + c@ <
|
716 |
|
|
if r> 1+ exit then
|
717 |
|
|
then
|
718 |
|
|
next 0x0000 ;
|
719 |
|
|
h: lookfor ( b u c xt -- b u : skip until *xt* test succeeds )
|
720 |
|
|
swap >r -rot
|
721 |
|
|
begin
|
722 |
|
|
dup
|
723 |
|
|
while
|
724 |
|
|
string@ r@ - r@ =bl = 4 pick execute
|
725 |
|
|
if rdrop rot-drop exit then
|
726 |
|
|
+string
|
727 |
|
|
repeat rdrop rot-drop ;
|
728 |
|
|
h: no-match if 0> exit then 0<> ; ( n f -- t )
|
729 |
|
|
h: match no-match invert ; ( n f -- t )
|
730 |
|
|
h: parser ( b u c -- b u delta )
|
731 |
|
|
>r over r> swap 2>r
|
732 |
|
|
r@ ' no-match lookfor 2dup
|
733 |
|
|
r> ' match lookfor swap r> - >r - r> 1+ ;
|
734 |
|
|
: parse ( c -- b u ; )
|
735 |
|
|
>r tib in@ + #tib @ in@ - r@ parser >in +!
|
736 |
|
|
r> =bl = if -trailing then 0 max ;
|
737 |
|
|
: ) ; immediate ( -- : do nothing )
|
738 |
|
|
: ( [char] ) parse 2drop ; immediate \ ) ( parse until matching paren )
|
739 |
|
|
: .( [char] ) parse type ; ( print out text until matching parenthesis )
|
740 |
|
|
: \ #tib @ in! ; immediate ( comment until new line )
|
741 |
|
|
h: ?length dup word-length u< ?exit $13 -throw ;
|
742 |
|
|
: word 1depth parse ?length here pack$ ; ( c -- a ; )
|
743 |
|
|
h: token =bl word ; ( -- a )
|
744 |
|
|
: char token count drop c@ ; ( -- c; )
|
745 |
|
|
h: ?dictionary dup $3B00 u< ?exit 8 -throw ;
|
746 |
|
|
: , here dup cell+ ?dictionary cp! ! ; ( u -- : store *u* in dictionary )
|
747 |
|
|
: 2, , , ; ( u u -- )
|
748 |
|
|
: c, here ?dictionary c! cp 1+! ; ( c -- : store *c* in the dictionary )
|
749 |
|
|
h: doLit 0x8000 or , ; ( n+ -- : compile literal )
|
750 |
|
|
: literal ( n -- : write a literal into the dictionary )
|
751 |
|
|
dup 0x8000 and ( n > $7FFF ? )
|
752 |
|
|
if
|
753 |
|
|
invert doLit =invert , exit ( store inversion of n the invert it )
|
754 |
|
|
then
|
755 |
|
|
doLit ; compile-only immediate ( turn into literal, write into dictionary )
|
756 |
|
|
h: make-callable chars $4000 or ; ( cfa -- instruction )
|
757 |
|
|
: compile, make-callable , ; ( cfa -- : compile a code field address )
|
758 |
|
|
h: $compile dup inline? if cfa @ , exit then cfa compile, ; ( pwd -- )
|
759 |
|
|
h: not-found source type $D -throw ; ( -- : throw 'word not found' )
|
760 |
|
|
h: ?compile dup compile-only? 0= ?exit source type $E -throw ;
|
761 |
|
|
xchange _forth-wordlist _system
|
762 |
|
|
: (literal) state@ 0= ?exit postpone literal ; ( u -- u | )
|
763 |
|
|
xchange _system _forth-wordlist
|
764 |
|
|
: interpret ( ??? a -- ??? : The command/compiler loop )
|
765 |
|
|
\ dup count type space ( <- for tracing the parser )
|
766 |
|
|
find ?dup if
|
767 |
|
|
state@
|
768 |
|
|
if
|
769 |
|
|
0> if cfa execute exit then \ <- immediate word are executed
|
770 |
|
|
$compile exit \ <- compiling word are...compiled.
|
771 |
|
|
then
|
772 |
|
|
drop ?compile \ <- check it's not a compile only word word
|
773 |
|
|
cfa execute exit \ <- if its not, execute it, then exit *interpreter*
|
774 |
|
|
then
|
775 |
|
|
\ not a word
|
776 |
|
|
dup>r count number? if rdrop \ it's a number!
|
777 |
|
|
dpl @ 0< if \ <- dpl will -1 if its a single cell number
|
778 |
|
|
drop \ drop high cell from 'number?' for single cell output
|
779 |
|
|
else \ <- dpl is not -1, it's a double cell number
|
780 |
|
|
state@ if swap then
|
781 |
|
|
@execute \ is executed twice if it's a double
|
782 |
|
|
then
|
783 |
|
|
@execute exit
|
784 |
|
|
then
|
785 |
|
|
r> not-found ; \ not a word/number, it's an error! NB. We could vector this
|
786 |
|
|
: compile r> dup@ , cell+ >r ; compile-only ( --:Compile next compiled word )
|
787 |
|
|
: immediate $40 last nfa fallthrough; ( -- : previous word immediate )
|
788 |
|
|
h: toggle tuck @ xor swap! ; ( u a -- : xor value at addr with u )
|
789 |
|
|
h: count+ count + ; ( b -- b : advance address over counted string )
|
790 |
|
|
h: do$ 2r> dup count+ aligned >r swap >r ; ( -- a )
|
791 |
|
|
h: string-literal do$ nop ; ( -- a : do string NB. nop to fool optimizer )
|
792 |
|
|
h: .string do$ fallthrough; ( -- : print string )
|
793 |
|
|
h: print count type ; ( b -- )
|
794 |
|
|
[t] .string tdoPrintString meta!
|
795 |
|
|
[t] string-literal tdoStringLit meta!
|
796 |
|
|
( , --, Run: -- b )
|
797 |
|
|
: $" compile string-literal fallthrough; immediate compile-only
|
798 |
|
|
h: parse-string [char] " word count+ cp! ; ( ccc" -- )
|
799 |
|
|
: ." compile .string parse-string ; immediate compile-only ( , -- )
|
800 |
|
|
: abort [-1] throw ; ( -- )
|
801 |
|
|
h: ?abort swap if print cr abort exit then drop ; ( u a -- )
|
802 |
|
|
h: (abort) do$ ?abort ; ( -- )
|
803 |
|
|
: abort" compile (abort) parse-string ; immediate compile-only ( u -- )
|
804 |
|
|
|
805 |
|
|
\ See:
|
806 |
|
|
\
|
807 |
|
|
\
|
808 |
|
|
\ For a super tiny N-bit PRNG use; "x+=(x*x) | 5;", you can only use the
|
809 |
|
|
\ highest bit however.
|
810 |
|
|
\ See:
|
811 |
|
|
: random
|
812 |
|
|
seed1 @ dup 5 lshift-xor
|
813 |
|
|
seed2 @ seed1 !
|
814 |
|
|
dup 3 rshift-xor
|
815 |
|
|
seed2 @ dup 1 rshift-xor xor dup seed2 ! ;
|
816 |
|
|
|
817 |
|
|
h: 40ns begin dup while 1- repeat drop ; ( n -- : wait for 'n'*40ns + 30us )
|
818 |
|
|
: ms for 25000 40ns next ; ( n -- : wait for 'n' milliseconds )
|
819 |
|
|
|
820 |
|
|
\ ============================================================================
|
821 |
|
|
\ # I/O wordset
|
822 |
|
|
|
823 |
|
|
|
824 |
|
|
xchange _forth-wordlist _system
|
825 |
|
|
: segments! $400E ! ; ( u -- : write to 4 7-segment hex displays )
|
826 |
|
|
: led! $4006 ! ; ( u -- : write to 8 LEDs )
|
827 |
|
|
: switches $4006 @ ; ( -- u : retrieve switch on/off for 8 switches )
|
828 |
|
|
: timer! $4004 ! ; ( u -- : set timer and timer control )
|
829 |
|
|
: timer $4004 @ ; ( -- u : get timer and timer control )
|
830 |
|
|
\ NB. Perhaps this could be vectored?
|
831 |
|
|
h: (irq)
|
832 |
|
|
( cpu? 0 cpu! )
|
833 |
|
|
switches led!
|
834 |
|
|
#irq dup@ segments! 1+!
|
835 |
|
|
( cpu! ) ;
|
836 |
|
|
[t] (irq) 2/ $C t!
|
837 |
|
|
: irq $0040 $4010 ! [-1] timer! 1 cpu! ;
|
838 |
|
|
|
839 |
|
|
\ FIFO: Write Read Enable after Read
|
840 |
|
|
\ h: uart? ( uart-register -- c -1 | 0 : generic UART input functions )
|
841 |
|
|
\ dup@ $0100 and if drop 0x0000 exit then dup@ $FF and swap $0400 swap! [-1] ;
|
842 |
|
|
\ FIFO: Write Read Enable before Read
|
843 |
|
|
h: uart? ( uart-register -- c -1 | 0 : generic UART input functions )
|
844 |
|
|
dup@ $0100 and if drop-0 exit then dup $0400 swap! @ lsb [-1] ;
|
845 |
|
|
|
846 |
|
|
: rx? $4000 uart? if [-1] exit then $4002 uart? ; ( -- c -1|0: rx uart/ps2 )
|
847 |
|
|
h: uart! ( c uart-register -- )
|
848 |
|
|
begin dup@ $1000 and 0= until swap $2000 or swap! ;
|
849 |
|
|
: tx! dup $4002 uart! ( VGA/VT-100 ) $4000 uart! ( UART ) ;
|
850 |
|
|
h: (ok) state@ if cr exit then ." ok" cr ; ( -- : default state aware prompt )
|
851 |
|
|
h: preset tib-start #tib cell+ ! 0 in! id zero ; ( -- : reset input )
|
852 |
|
|
: io! \ preset
|
853 |
|
|
( 115200 / 9600 )
|
854 |
|
|
$35 ( $28B ) $4012 ! ( set TX baud rate - 54 )
|
855 |
|
|
$34 ( $28A ) $4014 ! ( set RX baud rate - 53, hack! )
|
856 |
|
|
$8080 $4016 ! ( set UART control register; 8 bits, 1 stop, no parity )
|
857 |
|
|
|
858 |
|
|
|
859 |
|
|
fallthrough; ( -- : initialize I/O )
|
860 |
|
|
h: console ' rx? ! ' tx! ! fallthrough;
|
861 |
|
|
h: hand
|
862 |
|
|
' (ok)
|
863 |
|
|
' emit ' ktap
|
864 |
|
|
fallthrough;
|
865 |
|
|
h: xio ' accept ! ! ! ! ;
|
866 |
|
|
h: pace [char] . emit ;
|
867 |
|
|
: file ' pace ' drop ' ktap xio ;
|
868 |
|
|
|
869 |
|
|
\ ============================================================================
|
870 |
|
|
\ # Evaluation, Control Structures and Vocabulary Words
|
871 |
|
|
|
872 |
|
|
\ h: pace 11 emit ;
|
873 |
|
|
\ : file ' pace ' drop ' ktap xio ;
|
874 |
|
|
xchange _system _forth-wordlist
|
875 |
|
|
: ] [-1] state ! ; ( -- : compile mode )
|
876 |
|
|
: [ state zero ; immediate ( -- : command mode )
|
877 |
|
|
h: empty sp@ ndrop ; ( 0..n -- : empty variable stack )
|
878 |
|
|
h: ?error ( n -- : perform actions on error )
|
879 |
|
|
?dup 0= ?exit
|
880 |
|
|
. ( print error number )
|
881 |
|
|
[char] ? emit ( print '?' )
|
882 |
|
|
cr ( and terminate the line )
|
883 |
|
|
empty ( empty the variable stack )
|
884 |
|
|
fallthrough;
|
885 |
|
|
h: prequit ( perform actions needed to start 'quit' off )
|
886 |
|
|
preset ( reset I/O streams )
|
887 |
|
|
postpone [ ; ( back into interpret mode )
|
888 |
|
|
h: eval ( -- : evaluation loop, get token, evaluate, loop, prompt )
|
889 |
|
|
begin
|
890 |
|
|
token dup c@
|
891 |
|
|
while
|
892 |
|
|
interpret 0 ?depth
|
893 |
|
|
repeat drop @execute ;
|
894 |
|
|
: quit prequit begin query ' eval catch ?error again ;
|
895 |
|
|
h: get-input source in@ source-id @ ; ( -- n1...n5 )
|
896 |
|
|
h: set-input ! id ! in! #tib 2! ; ( n1...n5 -- )
|
897 |
|
|
: evaluate ( a u -- )
|
898 |
|
|
get-input 2>r 2>r >r
|
899 |
|
|
|
900 |
|
|
' eval catch
|
901 |
|
|
r> 2r> 2r> set-input
|
902 |
|
|
throw ;
|
903 |
|
|
h: ?check ( magic-number -- : check for magic number on the stack )
|
904 |
|
|
magic = ?exit $16 -throw ;
|
905 |
|
|
h: ?unique ( a -- a : print a message if a word definition is not unique )
|
906 |
|
|
dup get-current (search-wordlist) 0= ?exit
|
907 |
|
|
( source type )
|
908 |
|
|
space
|
909 |
|
|
2drop last-def @ .id ." redefined" cr ;
|
910 |
|
|
h: ?nul ( b -- : check for zero length strings )
|
911 |
|
|
dup c@ ?exit $A -throw ;
|
912 |
|
|
h: find-token token find fallthrough; ( -- pwd, )
|
913 |
|
|
h: ?not-found ?exit not-found ; ( t -- )
|
914 |
|
|
h: find-cfa find-token cfa ; ( -- xt, )
|
915 |
|
|
: ' find-cfa state@ if postpone literal exit then ; immediate
|
916 |
|
|
: [compile] find-cfa compile, ; immediate compile-only ( --, )
|
917 |
|
|
: [char] char postpone literal ; immediate compile-only ( --, )
|
918 |
|
|
: ; ?check =exit , postpone [ ( -- wid )
|
919 |
|
|
( h: get-current! ) ?dup if get-current ! exit then ; immediate compile-only
|
920 |
|
|
: : align here dup last-def ! ( "name", -- colon-sys )
|
921 |
|
|
last , token ?nul ?unique count+ cp! magic postpone ] ;
|
922 |
|
|
: begin here ; immediate compile-only ( -- a )
|
923 |
|
|
: again chars , ; immediate compile-only ( a -- )
|
924 |
|
|
: until $4000 or postpone again ; immediate compile-only ( a --, NB. again !? )
|
925 |
|
|
h: here-0 here 0x0000 ;
|
926 |
|
|
h: >mark here-0 postpone again ;
|
927 |
|
|
: if here-0 postpone until ; immediate compile-only
|
928 |
|
|
( : unless ' 0= compile, postpone if ; immediate compile-only )
|
929 |
|
|
: then fallthrough; immediate compile-only
|
930 |
|
|
h: >resolve here chars over @ or swap! ;
|
931 |
|
|
: else >mark swap >resolve ; immediate compile-only
|
932 |
|
|
: while postpone if ; immediate compile-only
|
933 |
|
|
: repeat swap postpone again postpone then ; immediate compile-only
|
934 |
|
|
h: last-cfa last-def @ cfa ; ( -- u )
|
935 |
|
|
: recurse last-cfa compile, ; immediate compile-only
|
936 |
|
|
: create postpone : drop compile doVar get-current ! postpone [ ;
|
937 |
|
|
: >body cell+ ; ( a -- a )
|
938 |
|
|
h: doDoes r> chars here chars last-cfa dup cell+ doLit h: !, ! , ;;
|
939 |
|
|
: does> compile doDoes nop ; immediate compile-only
|
940 |
|
|
: variable create 0 , ;
|
941 |
|
|
: constant create ' doConst make-callable here cell- !, ;
|
942 |
|
|
: :noname here-0 magic postpone ] ; ( NB. need postpone! )
|
943 |
|
|
: for =>r , here ; immediate compile-only
|
944 |
|
|
: next compile doNext , ; immediate compile-only
|
945 |
|
|
: aft drop >mark postpone begin swap ; immediate compile-only
|
946 |
|
|
: marker ( "name", -- : create an eraser )
|
947 |
|
|
here >r current @ dup@ r>
|
948 |
|
|
create , 2,
|
949 |
|
|
doDoes ( <- meta-compiler version of does> )
|
950 |
|
|
dup cell+ 2@ swap! @ here - allot ;
|
951 |
|
|
|
952 |
|
|
\ h: (do) r@ swap rot >r >r cell+ >r ; ( hi lo -- index )
|
953 |
|
|
\ : do compile (do) 0 , here ; compile-only immediate ( hi lo -- )
|
954 |
|
|
\ h: (leave) rdrop rdrop rdrop ; compile-only
|
955 |
|
|
\ : leave compile (leave) nop ; compile-only immediate
|
956 |
|
|
\ h: (loop)
|
957 |
|
|
\ r> r> 1+ r> 2dup-xor if
|
958 |
|
|
\ >r >r @ >r exit
|
959 |
|
|
\ then >r 1- >r cell+ >r ; compile-only
|
960 |
|
|
\ h: (unloop) r>rdrop rdrop rdrop >r ; compile-only
|
961 |
|
|
\ : unloop compile (unloop) nop ; compile-only immediate
|
962 |
|
|
\ h: (?do)
|
963 |
|
|
\ 2dup-xor if r@ swap rot >r >r cell+ >r exit then 2drop ; compile-only
|
964 |
|
|
\ : ?do compile (?do) 0 , here ; compile-only immediate ( hi lo -- )
|
965 |
|
|
\ : loop compile (loop) dup , compile (unloop) cell- here chars ( -- )
|
966 |
|
|
\ swap! ; compile-only immediate
|
967 |
|
|
\ h: (+loop)
|
968 |
|
|
\ r> swap r> r> 2dup - >r
|
969 |
|
|
\ 2 pick r@ + r@ xor 0< 0=
|
970 |
|
|
\ 3 pick r> xor 0< 0= or if
|
971 |
|
|
\ >r + >r @ >r exit
|
972 |
|
|
\ then >r >r drop cell+ >r ; compile-only
|
973 |
|
|
\ : +loop ( n -- ) compile (+loop) dup , compile
|
974 |
|
|
\ (unloop) cell- here chars swap! ; compile-only immediate
|
975 |
|
|
\ h: (i) 2r> tuck 2>r nop ; compile-only ( -- index )
|
976 |
|
|
\ : i compile (i) nop ; compile-only immediate ( -- index )
|
977 |
|
|
|
978 |
|
|
xchange _forth-wordlist _system
|
979 |
|
|
: hide find-token nfa $80 swap toggle ; ( --, : hide word by name )
|
980 |
|
|
xchange _system _forth-wordlist
|
981 |
|
|
: get-order ( -- widn ... wid1 n : get the current search order )
|
982 |
|
|
context
|
983 |
|
|
|
984 |
|
|
( : find-cell ) >r begin dup@ r@ xor while cell+ repeat rdrop ( ; u a -- a )
|
985 |
|
|
dup cell- swap
|
986 |
|
|
context - chars dup>r 1- s>d if $32 -throw exit then
|
987 |
|
|
for aft dup@ swap cell- then next @ r> ;
|
988 |
|
|
xchange _forth-wordlist root-voc
|
989 |
|
|
: forth-wordlist _forth-wordlist ; ( -- wid : push forth vocabulary )
|
990 |
|
|
: system _system ; ( -- wid : push system vocabulary )
|
991 |
|
|
: set-order ( widn ... wid1 n -- : set the current search order )
|
992 |
|
|
dup [-1] = if drop root-voc 1 set-order exit then ( NB. Recursion! )
|
993 |
|
|
dup #vocs > if $31 -throw exit then
|
994 |
|
|
context swap for aft tuck! cell+ then next zero ;
|
995 |
|
|
: forth root-voc forth-wordlist 2 set-order ; ( -- )
|
996 |
|
|
: words
|
997 |
|
|
get-order begin ?dup while
|
998 |
|
|
swap dup cr u. colon-space @
|
999 |
|
|
begin
|
1000 |
|
|
?dup
|
1001 |
|
|
while dup
|
1002 |
|
|
nfa c@ $80 and 0= ( <- not-hidden? )
|
1003 |
|
|
if dup .id then @
|
1004 |
|
|
repeat cr
|
1005 |
|
|
1- repeat ;
|
1006 |
|
|
xchange root-voc _forth-wordlist
|
1007 |
|
|
( : previous get-order nip 1- set-order ; ( -- )
|
1008 |
|
|
( : also get-order over swap 1+ set-order ; ( wid -- )
|
1009 |
|
|
: only [-1] set-order ; ( -- )
|
1010 |
|
|
( : order get-order for aft . then next cr ; ( -- )
|
1011 |
|
|
( : anonymous get-order 1+ here 1 cells allot swap set-order ; ( -- )
|
1012 |
|
|
: definitions context @ current ! ( <- set current ) ; ( -- )
|
1013 |
|
|
h: (order) ( w wid*n n -- wid*n w n )
|
1014 |
|
|
dup if
|
1015 |
|
|
1- swap >r (order) over r@ xor
|
1016 |
|
|
if
|
1017 |
|
|
1+ r> -rot exit
|
1018 |
|
|
then rdrop
|
1019 |
|
|
then ;
|
1020 |
|
|
: -order get-order (order) nip set-order ; ( wid -- )
|
1021 |
|
|
: +order dup>r -order get-order r> swap 1+ set-order ; ( wid -- )
|
1022 |
|
|
: editor editor-voc +order ; ( -- : load editor vocabulary )
|
1023 |
|
|
|
1024 |
|
|
\ ============================================================================
|
1025 |
|
|
\ # Block Wordset
|
1026 |
|
|
|
1027 |
|
|
\ h: updated? block-dirty @ ; ( -- f )
|
1028 |
|
|
: update [-1] block-dirty ! ; ( -- )
|
1029 |
|
|
\ h: +block blk-@ + ; ( n -- k )
|
1030 |
|
|
\ h: clean-buffers 0 block-dirty ! ;
|
1031 |
|
|
\ h: empty-buffers clean-buffers 0 blk ! ; ( -- )
|
1032 |
|
|
: flush
|
1033 |
|
|
blk-@ 0= block-dirty @ d0= ?exit
|
1034 |
|
|
block-buffer b/buf blk-@ @execute throw
|
1035 |
|
|
|
1036 |
|
|
|
1037 |
|
|
h: ?block if $23 -throw exit then ;
|
1038 |
|
|
: block ( k -- a )
|
1039 |
|
|
1depth
|
1040 |
|
|
dup 0= ?block ( check validity of block number )
|
1041 |
|
|
dup blk-@ = if drop block-buffer exit then ( block already loaded )
|
1042 |
|
|
flush
|
1043 |
|
|
dup>r block-buffer b/buf r> @execute throw
|
1044 |
|
|
blk!
|
1045 |
|
|
block-buffer ;
|
1046 |
|
|
|
1047 |
|
|
\ xchange _forth-wordlist _system
|
1048 |
|
|
\ : (block) ( a u k -- f )
|
1049 |
|
|
\ 1- dup $C u> ?block
|
1050 |
|
|
\ $A lshift ( <- b/buf * )
|
1051 |
|
|
\ -rot cmove 0x0000 ;
|
1052 |
|
|
\ : (save) 2drop drop-0 ; ( a u k -- f )
|
1053 |
|
|
\ xchange _system _forth-wordlist
|
1054 |
|
|
|
1055 |
|
|
\ ============================================================================
|
1056 |
|
|
\ # Memory Interface
|
1057 |
|
|
|
1058 |
|
|
\ The manual for the Nexys 3 board specifies that there is a PCM
|
1059 |
|
|
\ memory device called the NP8P128A13T1760E, this is a device behaves like
|
1060 |
|
|
\ normal flash with the addition that individual cells can be written to
|
1061 |
|
|
\ without first erasing the block, this is accomplished with an extension
|
1062 |
|
|
\ to the Common Flash Interface that most flash devices support. However,
|
1063 |
|
|
\ there are boards with the PC28F128P33BF60 on in lieu of this, which is a
|
1064 |
|
|
\ normal flash device without the "bit alterable write" extension. Normal
|
1065 |
|
|
\ flash memory works by erasing a block of data, which sets all the bits.
|
1066 |
|
|
\ Writing to the memory works by masking in a value as bits can be cleared in
|
1067 |
|
|
\ a memory cell but not set, they can only be set by erasing a block.
|
1068 |
|
|
\
|
1069 |
|
|
\ The Nexys 3 has three memory devices, two of which are accessed over
|
1070 |
|
|
\ a parallel interface. They share the same data and address bus, and
|
1071 |
|
|
\ can be selected with a chip select. The signals to be controlled
|
1072 |
|
|
\ are:
|
1073 |
|
|
\
|
1074 |
|
|
\ +-----+-------------------------+
|
1075 |
|
|
\ | Bit | Description |
|
1076 |
|
|
\ |-----|-------------------------|
|
1077 |
|
|
\ | 0-9 | Upper Memory Bits |
|
1078 |
|
|
\ | 10 | Flash chip select |
|
1079 |
|
|
\ | 11 | SRAM chip select |
|
1080 |
|
|
\ | 12 | Memory Wait [not used] |
|
1081 |
|
|
\ | 13 | Flash Reset |
|
1082 |
|
|
\ | 14 | Output Enable |
|
1083 |
|
|
\ | 15 | Write Enable |
|
1084 |
|
|
\ +-----+-------------------------+
|
1085 |
|
|
\
|
1086 |
|
|
\ The usage of the output enable and write enable are mutually exclusive,
|
1087 |
|
|
\ as are both of the chip selects. )
|
1088 |
|
|
\
|
1089 |
|
|
xchange _forth-wordlist _system
|
1090 |
|
|
|
1091 |
|
|
|
1092 |
|
|
|
1093 |
|
|
|
1094 |
|
|
|
1095 |
|
|
h: mdelay 5 40ns ;
|
1096 |
|
|
|
1097 |
|
|
h: mcontrol! ( u -- : write to memory control register )
|
1098 |
|
|
$F3FF and
|
1099 |
|
|
memory-select @ $400 + or ( select correct memory device )
|
1100 |
|
|
$1FF invert and ( mask off control bits )
|
1101 |
|
|
memory-upper @ $1FF and or ( or in higher address bits )
|
1102 |
|
|
$400A ! ; ( and finally write in control )
|
1103 |
|
|
|
1104 |
|
|
: m! ( n a -- : write to non-volatile memory )
|
1105 |
|
|
$400C !
|
1106 |
|
|
$4008 !
|
1107 |
|
|
mdelay
|
1108 |
|
|
0x8000 mcontrol!
|
1109 |
|
|
mdelay
|
1110 |
|
|
$0000 mcontrol! ;
|
1111 |
|
|
|
1112 |
|
|
: m@ ( a -- n : read from non-volatile memory )
|
1113 |
|
|
$400C !
|
1114 |
|
|
$4000 mcontrol! ( read enable mode )
|
1115 |
|
|
mdelay
|
1116 |
|
|
$4008 @ ( get input )
|
1117 |
|
|
$0000 mcontrol! ;
|
1118 |
|
|
|
1119 |
|
|
: sram $400 memory-select ! ;
|
1120 |
|
|
h: nvram $000 memory-select ! ;
|
1121 |
|
|
h: block-mode memory-upper @ memory-upper zero ; ( -- hi )
|
1122 |
|
|
h: flash-reset ( -- : reset non-volatile memory )
|
1123 |
|
|
$2000 mcontrol! mdelay $0000 mcontrol! ;
|
1124 |
|
|
h: flash! dup>r m! r> m! ; ( u u a )
|
1125 |
|
|
: flash-status nvram $70 0 m! 0 m@ ; ( -- status )
|
1126 |
|
|
: flash-read $FF 0 m! ; ( -- )
|
1127 |
|
|
: flash-setup memory-select @
|
1128 |
|
|
if flush then nvram flash-reset block-mode drop 20 ms ;
|
1129 |
|
|
h: flash-wait begin flash-status $80 and until ;
|
1130 |
|
|
: flash-clear $50 0 m! ; ( -- clear status )
|
1131 |
|
|
: flash-write $40 swap flash! flash-wait ; ( u a -- )
|
1132 |
|
|
\ : flash-unlock block-mode >r $d0 swap $60 swap flash! r> memory-upper ! ;
|
1133 |
|
|
\ : flash-lock block-mode >r $01 swap $60 swap flash! r> memory-upper ! ;
|
1134 |
|
|
\ : flash-lock-down block-mode >r $2f swap $60 swap flash! r> memory-upper ! ;
|
1135 |
|
|
: flash-erase block-mode >r flash-clear $D0 swap $20 swap
|
1136 |
|
|
flash! flash-wait r> memory-upper ! ; ( ba -- )
|
1137 |
|
|
: flash-query $98 0 m! ; ( -- : query mode )
|
1138 |
|
|
|
1139 |
|
|
( -- read id mode : does the same as flash-query on the PC28F128P33BF60 )
|
1140 |
|
|
\ : flash-read-id $90 0 m! ;
|
1141 |
|
|
|
1142 |
|
|
h: flash->sram ( a a : transfer flash memory cell to SRAM )
|
1143 |
|
|
nvram flash-clear flash-read
|
1144 |
|
|
m@ sram swap m! ;
|
1145 |
|
|
|
1146 |
|
|
: transfer ( a a u -- : transfer memory block from Flash to SRAM )
|
1147 |
|
|
?dup 0= if 2drop exit then
|
1148 |
|
|
1-
|
1149 |
|
|
for
|
1150 |
|
|
2dup
|
1151 |
|
|
flash->sram
|
1152 |
|
|
cell+ swap cell+ swap
|
1153 |
|
|
next 2drop ;
|
1154 |
|
|
\ .set flash-voc $pwd
|
1155 |
|
|
|
1156 |
|
|
h: c>m swap @ swap m! ; ( a a -- )
|
1157 |
|
|
h: m>c m@ swap! ; ( a a -- )
|
1158 |
|
|
|
1159 |
|
|
h: mblock ( a u k -- f )
|
1160 |
|
|
1- b/buf um* memory-upper ! >r
|
1161 |
|
|
begin
|
1162 |
|
|
dup
|
1163 |
|
|
while
|
1164 |
|
|
over r@ _blockop @execute r> cell+ >r
|
1165 |
|
|
cell /string
|
1166 |
|
|
repeat
|
1167 |
|
|
rdrop 2drop-0 ;
|
1168 |
|
|
|
1169 |
|
|
: (save) ' c>m _blockop ! mblock ;
|
1170 |
|
|
: (block) ' m>c _blockop ! mblock ;
|
1171 |
|
|
|
1172 |
|
|
\ ============================================================================
|
1173 |
|
|
\ # ANSI Escape Sequences
|
1174 |
|
|
|
1175 |
|
|
h: CSI $1B emit [char] [ emit ; ( -- )
|
1176 |
|
|
h: 10u. base@ >r decimal 0 <# #s #> type r> base! ; ( u -- )
|
1177 |
|
|
: ansi swap CSI 10u. emit ; ( n c -- )
|
1178 |
|
|
xchange _system _forth-wordlist
|
1179 |
|
|
: at-xy CSI 10u. $3B emit 10u. [char] H emit ; ( x y -- ) \ @execute
|
1180 |
|
|
: page 2 [char] J ansi 1 1 at-xy ; ( -- ) \ @execute
|
1181 |
|
|
xchange _forth-wordlist _system
|
1182 |
|
|
: sgr [char] m ansi ; ( -- : emit an SGR )
|
1183 |
|
|
: up [char] A ansi ; ( u -- : move the cursor up )
|
1184 |
|
|
: down [char] B ansi ; ( u -- : move the cursor down )
|
1185 |
|
|
: right [char] C ansi ; ( u -- : move the cursor right )
|
1186 |
|
|
: left [char] D ansi ; ( u -- : move the cursor left )
|
1187 |
|
|
|
1188 |
|
|
\ 0 constant black 1 constant red 2 constant green 4 constant blue
|
1189 |
|
|
\ red green + constant yellow
|
1190 |
|
|
\ green blue + constant cyan
|
1191 |
|
|
\ red blue + constant magenta
|
1192 |
|
|
\ red green blue + + constant white
|
1193 |
|
|
\ : background $A + ;
|
1194 |
|
|
\ : color $1E + sgr ;
|
1195 |
|
|
|
1196 |
|
|
h: tableu ( -- )
|
1197 |
|
|
$7 for
|
1198 |
|
|
$A right $7 r@ - $28 + dup sgr u. colon-space
|
1199 |
|
|
$7 for $7 r@ - $1E + dup sgr u. next cr
|
1200 |
|
|
next ;
|
1201 |
|
|
|
1202 |
|
|
: table page $2 down tableu 1 sgr $2 down tableu 0 sgr ; ( -- )
|
1203 |
|
|
\ : nuf? key? if drop [-1] exit then 0x0000 ; ( -- f )
|
1204 |
|
|
xchange _system _forth-wordlist
|
1205 |
|
|
|
1206 |
|
|
\ ============================================================================
|
1207 |
|
|
\ # Higher Level Block Words
|
1208 |
|
|
|
1209 |
|
|
h: c/l* ( c/l * ) 6 lshift ; ( u -- u )
|
1210 |
|
|
h: line c/l* swap block + c/l ; ( k u -- a u )
|
1211 |
|
|
\ h: loadline line evaluate ; ( k u -- )
|
1212 |
|
|
: load 0 $F for 2dup 2>r line evaluate 2r> 1+ next 2drop ; ( k -- )
|
1213 |
|
|
h: pipe [char] | emit ; ( -- )
|
1214 |
|
|
\ h: .line line -trailing $type ; ( k u -- )
|
1215 |
|
|
h: .border 3 spaces c/l [char] - nchars cr ; ( -- )
|
1216 |
|
|
: thru over- for dup load 1+ next drop ; ( k1 k2 -- )
|
1217 |
|
|
( : message l/b extract .line cr ; ( u -- )
|
1218 |
|
|
h: retrieve block drop ; ( k -- )
|
1219 |
|
|
: list ( k -- )
|
1220 |
|
|
dup retrieve
|
1221 |
|
|
cr
|
1222 |
|
|
.border
|
1223 |
|
|
|
1224 |
|
|
dup l/b <
|
1225 |
|
|
while
|
1226 |
|
|
2dup dup 2 u.r pipe line $type pipe cr 1+
|
1227 |
|
|
repeat .border 2drop ;
|
1228 |
|
|
|
1229 |
|
|
\ : list block l/b for dup l/b 1- r@ - c/l * + c/l type cr next ;
|
1230 |
|
|
|
1231 |
|
|
: index ( k1 k2 -- : show titles for block k1 to k2 )
|
1232 |
|
|
over- cr
|
1233 |
|
|
for
|
1234 |
|
|
dup 5u.r pipe space dup 0 line $type cr 1+
|
1235 |
|
|
next drop ;
|
1236 |
|
|
( : --> blk-@ 1+ load ; immediate )
|
1237 |
|
|
\ ============================================================================
|
1238 |
|
|
\ # Boot Sequence
|
1239 |
|
|
|
1240 |
|
|
\ We could select different behaviors depending on what switches were set at
|
1241 |
|
|
\ at start up, some for debugging, others for functionality.
|
1242 |
|
|
|
1243 |
|
|
h: bist ( -- u : built in self test )
|
1244 |
|
|
header-options @ first-bit 0= if 0x0000 exit then ( is checking disabled? )
|
1245 |
|
|
header-length @ here xor if 2 exit then ( length check )
|
1246 |
|
|
header-crc @ header-crc zero ( retrieve and zero CRC )
|
1247 |
|
|
|
1248 |
|
|
1 header-options toggle 0x0000 ; ( disable check, success )
|
1249 |
|
|
: bye fallthrough;
|
1250 |
|
|
h: cold ( -- : performs a cold boot )
|
1251 |
|
|
bist ?dup if negate dup bye exit then
|
1252 |
|
|
io! forth
|
1253 |
|
|
empty 0 rp!
|
1254 |
|
|
hex cr ." eFORTH v" cpu-id 0 u.r cr here . $4000 here - u. cr
|
1255 |
|
|
." loading..."
|
1256 |
|
|
|
1257 |
|
|
1 block c@ 32 127 within ( <- ASCII? ) if
|
1258 |
|
|
(ok) ( 1 load ) else ." failed" cr
|
1259 |
|
|
then quit ;
|
1260 |
|
|
|
1261 |
|
|
\ ============================================================================
|
1262 |
|
|
\ # Decompiler / Tools
|
1263 |
|
|
|
1264 |
|
|
h: validate over cfa xor if drop-0 exit then nfa ; ( pwd cfa -- nfa | 0 )
|
1265 |
|
|
h: search-for-cfa ( wid cfa -- nfa | 0 : search for CFA in a word list )
|
1266 |
|
|
cells $1FFF and >r
|
1267 |
|
|
begin
|
1268 |
|
|
dup
|
1269 |
|
|
while
|
1270 |
|
|
dup@ over r@ -rot within
|
1271 |
|
|
if dup@ r@ validate ?dup if rdrop nip exit then then
|
1272 |
|
|
@
|
1273 |
|
|
repeat rdrop ;
|
1274 |
|
|
h: name ( cwf -- a | 0 )
|
1275 |
|
|
>r
|
1276 |
|
|
get-order
|
1277 |
|
|
begin
|
1278 |
|
|
dup
|
1279 |
|
|
while
|
1280 |
|
|
swap r@ search-for-cfa ?dup if >r 1- ndrop r>rdrop exit then
|
1281 |
|
|
1- repeat rdrop ;
|
1282 |
|
|
( h: neg? dup 2 and if $FFFE or then ; )
|
1283 |
|
|
( h: .alu ( u -- )
|
1284 |
|
|
( dup 8 rshift $1F and 5u.r )
|
1285 |
|
|
( dup $80 and if ." t->n " then )
|
1286 |
|
|
( dup $40 and if ." t->r " then )
|
1287 |
|
|
( dup $10 and if ." r->pc " then )
|
1288 |
|
|
( dup $0C and [char] r emit 2 rshift neg? . space )
|
1289 |
|
|
( $03 and [char] d emit neg? . ; )
|
1290 |
|
|
h: ?instruction ( i m e -- i t )
|
1291 |
|
|
>r over-and r> = ;
|
1292 |
|
|
( a -- : find word by address, and print )
|
1293 |
|
|
h: .name dup $1FFF and cells 5u.r ( a -- )
|
1294 |
|
|
name ?dup if word.count type then ;
|
1295 |
|
|
h: decompile ( u -- : decompile a single instruction )
|
1296 |
|
|
0x8000 0x8000 ?instruction if [char] L emit $7FFF and 5u.r exit then
|
1297 |
|
|
$6000 $6000 ?instruction if [char] A emit drop ( .alu ) exit then
|
1298 |
|
|
$6000 $4000 ?instruction if [char] C emit .name exit then
|
1299 |
|
|
$6000 $2000 ?instruction if [char] Z emit .name exit then
|
1300 |
|
|
[char] B emit .name ;
|
1301 |
|
|
h: decompiler ( previous current -- : decompile starting at address )
|
1302 |
|
|
>r
|
1303 |
|
|
begin dup r@ u< while
|
1304 |
|
|
d5u.r colon-space
|
1305 |
|
|
dup@
|
1306 |
|
|
d5u.r decompile cr cell+
|
1307 |
|
|
repeat rdrop drop ;
|
1308 |
|
|
: see ( --, : decompile a word )
|
1309 |
|
|
token (find) ?not-found
|
1310 |
|
|
swap 2dup= if drop here then >r
|
1311 |
|
|
cr colon-space dup .id dup cr
|
1312 |
|
|
cfa r> decompiler space [char] ; emit
|
1313 |
|
|
dup compile-only? if ." compile-only" then
|
1314 |
|
|
dup inline? if ." inline" then
|
1315 |
|
|
immediate? if ." immediate" then cr ;
|
1316 |
|
|
: .s ( -- ) cr sp@ for aft r@ pick . then next ."
|
1317 |
|
|
: dump ( a u -- )
|
1318 |
|
|
$10 + \ align up by dump width
|
1319 |
|
|
4 rshift ( <-- equivalent to "dump-width /" )
|
1320 |
|
|
for
|
1321 |
|
|
aft
|
1322 |
|
|
cr $10 2dup
|
1323 |
|
|
over 5u.r colon-space
|
1324 |
|
|
chars for aft dup@ 5u.r cell+ then next ( <- dm+; [ a u -- ] )
|
1325 |
|
|
-rot
|
1326 |
|
|
2 spaces $type
|
1327 |
|
|
then
|
1328 |
|
|
next drop ;
|
1329 |
|
|
\ ============================================================================
|
1330 |
|
|
\ # Block Editor
|
1331 |
|
|
|
1332 |
|
|
[last] [t] _forth-wordlist t!
|
1333 |
|
|
[t] _forth-wordlist [v] current t!
|
1334 |
|
|
|
1335 |
|
|
h: [block] blk-@ block ; ( k -- a : loaded block address )
|
1336 |
|
|
h: [check] dup b/buf 6 rshift u< ?exit $18 -throw ;
|
1337 |
|
|
h: [line] [check] c/l* [block] + ; ( u -- a )
|
1338 |
|
|
: b retrieve ; ( k -- : Load a block )
|
1339 |
|
|
: l blk-@ list ; ( -- : list current block )
|
1340 |
|
|
: n 1 h: +blv blk-@ + b l ;; ( -- : load and list Next block )
|
1341 |
|
|
: p [-1] +blv ; ( -- : load and list Previous block )
|
1342 |
|
|
: d [block] b/buf h: blank =bl fill ;; ( -- : Zero/blank loaded block )
|
1343 |
|
|
: k [line] c/l blank ; ( u -- : delete/Kill line )
|
1344 |
|
|
: s update flush ; ( -- : Save changes to disk )
|
1345 |
|
|
: q editor-voc -order ; ( -- : Quit editor )
|
1346 |
|
|
: x q blk-@ load editor ; ( -- : eXecute/evaluate block )
|
1347 |
|
|
: ia c/l* + [block] + tib in@ + ( u u -- Insert At )
|
1348 |
|
|
swap source nip in@ - cmove postpone \ ;
|
1349 |
|
|
: i 0 swap ia ; ( u -- : Insert line )
|
1350 |
|
|
( : u update ; ( -- : set block set as dirty )
|
1351 |
|
|
( : w words ; )
|
1352 |
|
|
( : yank pad c/l ; )
|
1353 |
|
|
( : c [line] yank >r swap r> cmove ; )
|
1354 |
|
|
( : y [line] yank cmove ; )
|
1355 |
|
|
( : ct swap y c ; )
|
1356 |
|
|
( : xa [line] c/l evaluate ; )
|
1357 |
|
|
( : sw 2dup y [line] swap [line] swap c/l cmove c ; )
|
1358 |
|
|
[last] [t] editor-voc t! 0 tlast meta!
|
1359 |
|
|
|
1360 |
|
|
\ ============================================================================
|
1361 |
|
|
\ # Final Touches
|
1362 |
|
|
there [t] cp t!
|
1363 |
|
|
[t] (literal) [v] t! ( set literal execution vector )
|
1364 |
|
|
[t] (block) [v] t! ( set block execution vector )
|
1365 |
|
|
[t] (save) [v] t! ( set block execution vector )
|
1366 |
|
|
[t] cold 2/ 0 t! ( set starting word in boot-loader )
|
1367 |
|
|
there [t] header-length t! \ Set Length First!
|
1368 |
|
|
checksum [t] header-crc t! \ Calculate image CRC
|
1369 |
|
|
finished
|
1370 |
|
|
bye
|