← Back to branch summary

~ubuntu-branches/ubuntu/wily/slof/wily

« back to all changes in this revision

Viewing changes to slof/engine.in

  • Committer: Package Import Robot
  • Author(s): Aurelien Jarno
  • Date: 2012-09-16 23:05:23 UTC
  • Revision ID: package-import@ubuntu.com-20120916230523-r2ynulqmp2tyu2e5
Tags: upstream-20120217+dfsg
Import upstream version 20120217+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
slof/engine.in
 
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
// ============================================================================
 
14
 
 
15
 
 
16
//
 
17
// Copyright 2002,2003,2004  Segher Boessenkool  <segher@kernel.crashing.org>
 
18
//
 
19
 
 
20
// This is the core engine of Paflof.  It is almost ANS Forth compatible.
 
21
// There are two possibilities why an aspect would not be:
 
22
//   a) Open Firmware requires different semantics;
 
23
//   b) bugs.
 
24
// Most of the "extended" semantics defined in the OF specification are
 
25
// not implemented; just the bare essentials.  For example, you can't
 
26
// use structural words (IF, THEN, BEGIN, etc.) or return-stack
 
27
// manipulation words (R> etc.) in the interpreter.
 
28
 
 
29
// The data stack pointer.
 
30
raw(HERE DOVAL _A(the_mem))
 
31
 
 
32
// Some common constant numbers; smaller and faster if they are defined
 
33
// as constants, than when inlined as a literal.
 
34
con(-1 -1)
 
35
con(0 0)
 
36
con(1 1)
 
37
con(2 2)
 
38
con(3 3)
 
39
con(4 4)
 
40
con(8 8)
 
41
con(H#10 0x10)
 
42
con(H#20 0x20)
 
43
con(H#FF 0xff)
 
44
con(H#FFFF 0xffff)
 
45
con(H#FFFFFFFF 0xffffffff)
 
46
con(D#10 0x0a)
 
47
 
 
48
 
 
49
// Manipulating different kinds of addresses.
 
50
con(/C 1)
 
51
con(/W 2)
 
52
con(/L 4)
 
53
con(/X 8)
 
54
con(/N CELLSIZE)
 
55
con(CELL CELLSIZE)
 
56
col(/C* /C *)
 
57
col(/W* /W *)
 
58
col(/L* /L *)
 
59
col(/X* /X *)
 
60
col(/N* /N *)
 
61
col(CA+ /C* +)
 
62
col(WA+ /W* +)
 
63
col(LA+ /L* +)
 
64
col(XA+ /X* +)
 
65
col(NA+ /N* +)
 
66
col(CA1+ /C +)
 
67
col(WA1+ /W +)
 
68
col(LA1+ /L +)
 
69
col(XA1+ /X +)
 
70
col(NA1+ /N +)
 
71
col(CHAR+ CA1+)
 
72
col(CELL+ NA1+)
 
73
col(CHAR- /C -)
 
74
col(CELL- /N -)
 
75
col(CHARS /C*)
 
76
col(CELLS /N*)
 
77
col(CHARS+ CA+)
 
78
col(CELLS+ NA+)
 
79
 
 
80
 
 
81
// Run-time words for TO and for string literals.
 
82
col(DOTO R> CELL+ DUP >R @ CELL+ !)
 
83
col(SLITERAL R> CELL+ DUP DUP C@ + LIT(-CELLSIZE) AND >R)
 
84
 
 
85
 
 
86
// Stack manipulation.
 
87
col(?DUP DUP 0BRANCH(1) DUP)
 
88
col(TUCK SWAP OVER)
 
89
col(2DUP OVER OVER)
 
90
col(3DUP 2 PICK 2 PICK 2 PICK)
 
91
col(2OVER 3 PICK 3 PICK)
 
92
col(2DROP DROP DROP)
 
93
col(3DROP DROP DROP DROP)
 
94
col(NIP SWAP DROP)
 
95
col(CLEAR 0 DEPTH!)
 
96
col(ROT >R SWAP R> SWAP)
 
97
col(-ROT SWAP >R SWAP R>)
 
98
col(2SWAP >R -ROT R> -ROT)
 
99
col(2ROT >R >R 2SWAP R> R> 2SWAP)
 
100
col(ROLL DUP ?DUP 0BRANCH(6) ROT >R 1 - BRANCH(-9) ?DUP 0BRANCH(6) R> -ROT 1 - BRANCH(-9))
 
101
col(-ROLL DUP ?DUP 0BRANCH(9) >R ROT R> SWAP >R 1 - BRANCH(-12) ?DUP 0BRANCH(6) R> SWAP 1 - BRANCH(-9))
 
102
col(2>R R> ROT >R SWAP >R >R)
 
103
col(2R> R> R> R> ROT >R SWAP)
 
104
col(2R@ R> R> R@ OVER >R ROT >R SWAP)
 
105
cod(?PICK)
 
106
 
 
107
// Arithmetic.
 
108
col(2* 1 LSHIFT)
 
109
col(U2/ 1 RSHIFT)
 
110
col(2/ 1 ASHIFT)
 
111
col(<< LSHIFT)
 
112
col(>> RSHIFT)
 
113
col(>>A ASHIFT)
 
114
col(INVERT -1 XOR)
 
115
col(NOT INVERT)
 
116
 
 
117
 
 
118
// Booleans.
 
119
con(TRUE -1)
 
120
con(FALSE 0)
 
121
 
 
122
 
 
123
// Comparisons.
 
124
col(> SWAP <)
 
125
col(U> SWAP U<)
 
126
col(<= > 0=)
 
127
col(<> = 0=)
 
128
col(>= < 0=)
 
129
col(0<= 0 <=)
 
130
col(0<> 0 <>)
 
131
col(0> 0 >)
 
132
col(0>= 0 >=)
 
133
col(U<= U> 0=)
 
134
col(U>= U< 0=)
 
135
col(WITHIN ROT DUP ROT >= 0BRANCH(3) 2DROP FALSE EXIT > 0BRANCH(2) FALSE EXIT TRUE)
 
136
col(BETWEEN 1 + WITHIN)
 
137
 
 
138
// Double-cell single-bit shifts.
 
139
col(D2* 2* OVER 0< - >R 2* R>)
 
140
col(UD2/ >R U2/ R@ LIT(8*CELLSIZE-1) LSHIFT OR R> U2/)
 
141
col(D2/ >R U2/ R@ LIT(8*CELLSIZE-1) LSHIFT OR R> 2/)
 
142
 
 
143
 
 
144
// More arithmetic.
 
145
col(NEGATE 0 SWAP -)
 
146
col(ABS DUP 0< 0BRANCH(1) NEGATE)
 
147
col(MAX 2DUP < 0BRANCH(1) SWAP DROP)
 
148
col(MIN 2DUP > 0BRANCH(1) SWAP DROP)
 
149
col(U* *)
 
150
col(1+ 1 +)
 
151
col(1- 1 -)
 
152
col(2+ 2 +)
 
153
col(2- 2 -)
 
154
col(EVEN 1+ -1 AND)
 
155
col(BOUNDS OVER + SWAP)
 
156
 
 
157
 
 
158
// Double-cell and mixed-size arithmetic.
 
159
col(S>D DUP 0<)
 
160
col(DNEGATE INVERT >R NEGATE DUP 0= R> SWAP -)
 
161
col(DABS DUP 0< 0BRANCH(1) DNEGATE)
 
162
col(M+ SWAP >R DUP >R + DUP R> U< R> SWAP -)
 
163
col(D+ >R M+ R> +)
 
164
col(D- DNEGATE D+)
 
165
col(*' >R DUP 0< >R D2* R> 0BRANCH(2) R@ M+ R>)
 
166
col(UM* 0 -ROT LIT(8*CELLSIZE) 0 DODO *' DOLOOP(-3) DROP)
 
167
col(M* 2DUP XOR >R >R ABS R> ABS UM* R> 0< 0BRANCH(1) DNEGATE)
 
168
col(/' >R DUP 0< >R D2* R> OVER R@ U>= OR 0BRANCH(6) >R 1 OR R> R@ - R>)
 
169
col(UM/MOD LIT(8*CELLSIZE) 0 DODO /' DOLOOP(-3) DROP SWAP)
 
170
col(SM/REM OVER >R >R DABS R@ ABS UM/MOD R> 0< 0BRANCH(1) NEGATE R> 0< 0BRANCH(4) NEGATE SWAP NEGATE SWAP)
 
171
col(FM/MOD DUP >R 2DUP XOR 0< >R SM/REM OVER 0<> R> AND 0BRANCH(6) 1- SWAP R> + SWAP EXIT R> DROP)
 
172
 
 
173
 
 
174
// Division.
 
175
col(U/MOD 0 SWAP UM/MOD)
 
176
col(/MOD >R S>D R> FM/MOD)
 
177
col(/ /MOD NIP)
 
178
col(MOD /MOD DROP)
 
179
col(*/MOD >R M* R> FM/MOD)
 
180
col(*/ */MOD NIP)
 
181
 
 
182
 
 
183
// Splitting, joining, flipping the components of a number.
 
184
col(WBSPLIT DUP H#FF AND SWAP 8 RSHIFT)
 
185
col(LWSPLIT DUP H#FFFF AND SWAP H#10 RSHIFT)
 
186
col(XLSPLIT DUP H#FFFFFFFF AND SWAP H#20 RSHIFT)
 
187
col(LBSPLIT LWSPLIT >R WBSPLIT R> WBSPLIT)
 
188
col(XWSPLIT XLSPLIT >R LWSPLIT R> LWSPLIT)
 
189
col(XBSPLIT XLSPLIT >R LBSPLIT R> LBSPLIT)
 
190
col(BWJOIN 8 LSHIFT OR)
 
191
col(WLJOIN H#10 LSHIFT OR)
 
192
col(BLJOIN BWJOIN >R BWJOIN R> WLJOIN)
 
193
col(WBFLIP WBSPLIT SWAP BWJOIN)
 
194
col(LWFLIP LWSPLIT SWAP WLJOIN)
 
195
col(LXJOIN H#20 LSHIFT OR)
 
196
col(XLFLIP XLSPLIT SWAP LXJOIN)
 
197
col(LBFLIP LBSPLIT SWAP 2SWAP SWAP BLJOIN)
 
198
col(WXJOIN WLJOIN >R WLJOIN R> LXJOIN)
 
199
col(XWFLIP XWSPLIT SWAP 2SWAP SWAP WXJOIN)
 
200
col(BXJOIN BLJOIN >R BLJOIN R> LXJOIN)
 
201
col(XBFLIP XLSPLIT LBFLIP SWAP LBFLIP LXJOIN)
 
202
 
 
203
// Aligning to cell size.
 
204
col(ALIGNED /N 1- + /N NEGATE AND)
 
205
 
 
206
 
 
207
// Counted loop stuff.
 
208
col(I R> R@ SWAP >R)
 
209
col(J R> R> R> R@ SWAP >R SWAP >R SWAP >R)
 
210
col(UNLOOP R> R> R> 2DROP >R)
 
211
 
 
212
 
 
213
// Memory accesses.
 
214
col(+! TUCK @ + SWAP !)
 
215
cod(COMP)
 
216
col(OFF FALSE SWAP !)
 
217
col(ON TRUE SWAP !)
 
218
col(<W@ W@ DUP LIT(0x8000) >= 0BRANCH(3) LIT(0x10000) -)
 
219
col(2@ DUP CELL+ @ SWAP @)
 
220
col(2! DUP >R ! R> CELL+ !)
 
221
col(WBFLIPS BOUNDS DO?DO(8) I W@ WBFLIP I W! /W DO+LOOP(-8))
 
222
col(LWFLIPS BOUNDS DO?DO(8) I L@ LWFLIP I L! /L DO+LOOP(-8))
 
223
col(LBFLIPS BOUNDS DO?DO(8) I L@ LBFLIP I L! /L DO+LOOP(-8))
 
224
col(XBFLIPS BOUNDS DO?DO(8) I X@ XBFLIP I X! /X DO+LOOP(-8))
 
225
col(XWFLIPS BOUNDS DO?DO(8) I X@ XWFLIP I X! /X DO+LOOP(-8))
 
226
col(XLFLIPS BOUNDS DO?DO(8) I X@ XLFLIP I X! /X DO+LOOP(-8))
 
227
cod(FILL)
 
228
col(BLANK LIT(0x20) FILL)
 
229
col(ERASE LIT(0x00) FILL)
 
230
 
 
231
 
 
232
// Exception handling.
 
233
var(CATCHER 0)
 
234
var(ABORT"-STR 0)
 
235
col(CATCH DEPTH >R CATCHER @ >R RDEPTH CATCHER ! EXECUTE R> CATCHER ! R> DROP 0)
 
236
col(THROW ?DUP 0BRANCH(12) CATCHER @ RDEPTH! R> CATCHER ! R> SWAP >R DEPTH! DROP R>)
 
237
col(ABORT -1 THROW)
 
238
 
 
239
 
 
240
// Text input.
 
241
var(#TIB TIBSIZE)
 
242
val(IB 0)
 
243
var(#IB 0)
 
244
val(SOURCE-ID 0)
 
245
col(SOURCE IB #IB @)
 
246
var(>IN 0)
 
247
col(TERMINAL TIB DOTO IB #TIB @ #IB ! 0 DOTO SOURCE-ID)
 
248
 
 
249
 
 
250
// ASCII codes.
 
251
con(BL 0x20)
 
252
con(BELL 7)
 
253
con(BS 8)
 
254
con(CARRET 0x0d)
 
255
con(LINEFEED 0x0a)
 
256
 
 
257
 
 
258
// Text output.
 
259
dfr(EMIT)
 
260
dfr(CR)
 
261
col(TYPE BOUNDS DO?DO(5) I C@ EMIT DOLOOP(-5))
 
262
col(LL-CR CARRET EMIT LINEFEED EMIT)
 
263
col(SPACE BL EMIT)
 
264
col(SPACES 0 DO?DO(3) SPACE DOLOOP(-3))
 
265
 
 
266
 
 
267
// Text manipulation.
 
268
col(COUNT DUP CHAR+ SWAP C@)
 
269
col(PACK DUP >R 1+ SWAP DUP R@ C! MOVE R>)
 
270
col(UPC DUP LIT('a') LIT('z') BETWEEN 0BRANCH(3) LIT(0x20) - )
 
271
col(LCC DUP LIT('A') LIT('Z') BETWEEN 0BRANCH(3) LIT(0x20) + )
 
272
 
 
273
 
 
274
// Text input.
 
275
dfr(KEY)
 
276
dfr(KEY?)
 
277
dfr(ACCEPT)
 
278
var(SPAN 0)
 
279
col(EXPECT ACCEPT SPAN !)
 
280
col(REFILL SOURCE-ID 0= 0BRANCH(7) SOURCE EXPECT 0 >IN ! TRUE EXIT SOURCE-ID -1 = 0BRANCH(2) FALSE EXIT LIT(0x6502) THROW)
 
281
 
 
282
 
 
283
// Number base.
 
284
var(BASE 16)
 
285
col(DECIMAL D#10 BASE !)
 
286
col(HEX H#10 BASE !)
 
287
col(OCTAL 8 BASE !)
 
288
 
 
289
 
 
290
// Pictured numeric output.
 
291
col(PAD HERE LIT(256) +)
 
292
col(TODIGIT DUP LIT(9) > 0BRANCH(3) LIT(0x27) + LIT(0x30) +)
 
293
col(MU/MOD DUP >R U/MOD R> SWAP >R UM/MOD R>)
 
294
col(<# PAD DUP !)
 
295
col(HOLD PAD DUP @ 1- TUCK SWAP ! C!)
 
296
col(SIGN 0< 0BRANCH(3) LIT('-') HOLD)
 
297
col(# BASE @ MU/MOD ROT TODIGIT HOLD)
 
298
col(#S # 2DUP OR 0BRANCH(2) BRANCH(-7))
 
299
col(#> 2DROP PAD DUP @ TUCK -)
 
300
col((.) <# DUP >R ABS 0 #S R> SIGN #>)
 
301
col(U# BASE @ U/MOD SWAP TODIGIT HOLD)
 
302
col(U#S U# DUP 0BRANCH(2) BRANCH(-6))
 
303
col(U#> DROP PAD DUP @ TUCK -)
 
304
col((U.) <# U#S U#>)
 
305
col(. (.) TYPE SPACE)
 
306
col(S. .)
 
307
col(U. (U.) TYPE SPACE)
 
308
col(.R SWAP (.) ROT 2DUP < 0BRANCH(5) OVER - SPACES BRANCH(1) DROP TYPE)
 
309
col(U.R SWAP (U.) ROT 2DUP < 0BRANCH(5) OVER - SPACES BRANCH(1) DROP TYPE)
 
310
col(.D BASE @ SWAP DECIMAL . BASE !)
 
311
col(.H BASE @ SWAP HEX . BASE !)
 
312
col(.S DEPTH DUP 0< 0BRANCH(2) DROP EXIT 0 DO?DO(8) DEPTH I - 1- PICK . DOLOOP(-8))
 
313
col(? @ .)
 
314
 
 
315
 
 
316
// Numeric input.
 
317
col(DIGIT OVER UPC DUP LIT('A') LIT('Z') BETWEEN 0BRANCH(3) LIT(7) - LIT(0x30) - DUP ROT 0 SWAP WITHIN 0BRANCH(4) NIP TRUE BRANCH(2) DROP FALSE)
 
318
col(>NUMBER DUP 0= 0BRANCH(1) EXIT OVER C@ BASE @ DIGIT 0BRANCH(23) SWAP >R SWAP >R >R BASE @ U* SWAP BASE @ UM* ROT + R> 0 D+ R> CHAR+ R> 1- BRANCH(-35) DROP)
 
319
col($NUMBER DUP 0= 0BRANCH(4) DROP DROP TRUE EXIT >R DUP >R C@ LIT('-') = DUP 0BRANCH(15) R> CHAR+ R> 1- DUP 0= 0BRANCH(5) DROP DROP DROP TRUE EXIT >R >R 0 0 R> R> >NUMBER NIP 0= 0BRANCH(7) DROP SWAP 0BRANCH(1) NEGATE FALSE EXIT DROP DROP DROP TRUE)
 
320
 
 
321
 
 
322
// Data space allocation.
 
323
col(ALLOT HERE + DOTO HERE)
 
324
col(, HERE ! /N ALLOT)
 
325
col(C, HERE C! /C ALLOT)
 
326
col(W, HERE W! /W ALLOT)
 
327
col(L, HERE L! /L ALLOT)
 
328
col(X, HERE X! /X ALLOT)
 
329
col(ALIGN HERE /N 1- AND 0BRANCH(4) 0 C, BRANCH(-10))
 
330
col(PLACE 2DUP C! CHAR+ SWAP CHARS BOUNDS DO?DO(9) DUP C@ I C! CHAR+ 1 CHARS DO+LOOP(-9) DROP)
 
331
col(STRING, HERE OVER 1+ CHARS ALLOT PLACE)
 
332
 
 
333
 
 
334
// Every language needs a no-op.
 
335
col(NOOP)
 
336
 
 
337
 
 
338
// Now it gets ugly: search-order and word-lisst infrastructure.
 
339
 
 
340
raw(FORTH-WORDLIST DODOES _A(xt_NOOP+2+(8/sizeof(long))) _A(0) _A(0))
 
341
        // Engine initialisation will set this last cell to the xt of LASTWORD.
 
342
 
 
343
// compilation dictionary
 
344
raw(CURRENT DOVAL _A(xt_FORTH_X2d_WORDLIST+3+(16/sizeof(long))))
 
345
        // +7 for 32-bit, +5 for 64-bit
 
346
 
 
347
col(LAST CURRENT CELL+)
 
348
 
 
349
// for context dictionaries
 
350
raw(SEARCH-ORDER DOVAR _A(xt_FORTH_X2d_WORDLIST+3+(16/sizeof(long))) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0))
 
351
        // +7 for 32-bit, +5 for 64-bit
 
352
// for context dictionaries
 
353
//raw(SEARCH-ORDER DOVAR _A(xt_FORTH_X2d_WORDLIST+3+(sizeof("  FORTH-WORDLIST")/sizeof(long))) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0))
 
354
// +7 for 32-bit, +5 for 64-bit
 
355
raw(CONTEXT DOVAL _A(xt_SEARCH_X2d_ORDER+2+(16/sizeof(long))))
 
356
//raw(CONTEXT DOVAL _A(xt_SEARCH_X2d_ORDER+6))
 
357
// +6 for 32-bit, +4 for 64-bit
 
358
 
 
359
// Dictionary structure.
 
360
col(LINK>NAME CELL+)
 
361
col(NAME> CHAR+ DUP C@ 1+ CHARS+ ALIGNED)
 
362
col(LINK> LINK>NAME NAME>)
 
363
col(NAME>STRING CHAR+ COUNT)
 
364
 
 
365
// Creating word headers.
 
366
var(LATEST 0)
 
367
dfr((REVEAL))
 
368
col(HEADER ALIGN HERE LAST @ , LATEST ! 0 C, STRING, ALIGN)
 
369
col(REVEAL   LATEST @ LINK>NAME NAME>STRING (REVEAL) LATEST @ LAST !)
 
370
 
 
371
 
 
372
// Finding words.
 
373
cod(STRING=CI)
 
374
// (find) ( str len head -- 0 | link )
 
375
dfr((FIND))
 
376
col(((FIND)) DUP 0BRANCH(15) >R 2DUP R@ LINK>NAME NAME>STRING STRING=CI 0BRANCH(3) 2DROP R> EXIT R> @ BRANCH(-18) 3DROP FALSE)
 
377
col((FIND-ORDER) CONTEXT DUP >R SEARCH-ORDER U>= 0BRANCH(18) 2DUP R@ @ CELL+ @ (FIND) ?DUP 0BRANCH(5) NIP NIP R> DROP EXIT R> CELL- BRANCH(-24) R> 3DROP 0)
 
378
col(($FIND) (FIND-ORDER) DUP 0BRANCH(6) LINK>NAME DUP NAME> SWAP C@ TRUE)
 
379
col($FIND 2DUP ($FIND) 0BRANCH(6) DROP NIP NIP TRUE BRANCH(1) FALSE)
 
380
 
 
381
// Flags on words.
 
382
con('IMMEDIATE 1)
 
383
col(IMMEDIATE? 'IMMEDIATE AND 0<>)
 
384
col(IMMEDIATE LAST @ CELL+ DUP C@ 'IMMEDIATE OR SWAP C!)
 
385
 
 
386
// Parsing.
 
387
col(FINDCHAR SWAP 0 DO?DO(24) OVER I + C@ OVER DUP BL = 0BRANCH(3) <= BRANCH(1) = 0BRANCH(6) I UNLOOP NIP NIP TRUE EXIT DOLOOP(-24) DROP DROP FALSE)
 
388
col(PARSE >R IB >IN @ + SPAN @ >IN @ - 2DUP R> FINDCHAR 0BRANCH(6) NIP DUP 1 + BRANCH(1) DUP >IN +!)
 
389
col(SKIPWS IB SPAN @ DUP >IN @ > 0BRANCH(14) OVER >IN @ + C@ BL <= 0BRANCH(5) 1 >IN +! BRANCH(-20) DROP DROP)
 
390
col(PARSE-WORD SKIPWS BL PARSE)
 
391
var(WHICHPOCKET 0)
 
392
// We reserved 0x1000 for the pockets. So we have 16 pockets a 0x100
 
393
col(POCKET POCKETS WHICHPOCKET @ LIT(POCKETSIZE) * + WHICHPOCKET @ 1 + DUP LIT(NUMPOCKETS) = 0BRANCH(2) DROP 0 WHICHPOCKET !)
 
394
 
 
395
col(WORD POCKET >R PARSE DUP R@ C! BOUNDS R> DUP 2SWAP DO?DO(7) CHAR+ I C@ OVER C! DOLOOP(-7) DROP)
 
396
 
 
397
// Some simple parsing words.
 
398
col(CHAR PARSE-WORD DROP C@)
 
399
imm(( LIT(')') PARSE 2DROP)
 
400
// Removing comments out of the code, the code from the backslash to the next \n is removed.
 
401
// We need to start from cursor -1 (the backslash) to handle the case backslash+linefeed correctly 0x5c0a
 
402
imm(\ >IN @ 1- >IN ! LINEFEED PARSE 2DROP)
 
403
 
 
404
// The compiler infrastructure.
 
405
var(STATE 0)
 
406
imm([ STATE OFF)
 
407
col(] LIT(0x100) STATE !)
 
408
col(?COMP STATE @ 0BRANCH(1) EXIT LIT(-134) THROW)
 
409
 
 
410
col(COMPILE, ,)
 
411
col(: PARSE-WORD HEADER DOTICK DOCOL COMPILE, ])
 
412
col(:NONAME ALIGN HERE DOTICK DOCOL COMPILE, ])
 
413
imm(; ?COMP DOTICK SEMICOLON COMPILE, REVEAL [)
 
414
 
 
415
// Compiling strings.
 
416
imm(C" ?COMP LIT('"') PARSE DOTICK SLITERAL COMPILE, DUP C, BOUNDS DO?DO(5) I C@ C, DOLOOP(-5) ALIGN)
 
417
imm(S" STATE @ 0BRANCH(5) C" DOTICK COUNT COMPILE, EXIT LIT('"') PARSE DUP >R POCKET DUP >R SWAP MOVE R> R>)
 
418
imm(Z" S" 2DUP + 0 SWAP C! DROP)
 
419
imm(." STATE @ 0BRANCH(5) S" DOTICK TYPE COMPILE, EXIT  LIT('"') PARSE TYPE)
 
420
imm(.( LIT(')') PARSE TYPE)
 
421
 
 
422
col(COMPILE R> CELL+ DUP @ COMPILE, >R)
 
423
 
 
424
var(THERE 0)
 
425
col(+COMP STATE @ 1 STATE +! 0BRANCH(1) EXIT HERE THERE ! COMP-BUFFER DOTO HERE COMPILE DOCOL)
 
426
col(-COMP -1 STATE +! STATE @ 0BRANCH(1) EXIT COMPILE EXIT THERE @ DOTO HERE COMP-BUFFER EXECUTE)
 
427
 
 
428
// Structure words.
 
429
col(RESOLVE-ORIG HERE OVER CELL+ - SWAP !)
 
430
imm(AHEAD +COMP DOTICK DOBRANCH COMPILE, HERE 0 COMPILE,)
 
431
imm(IF +COMP DOTICK DO0BRANCH COMPILE, HERE 0 COMPILE,)
 
432
imm(THEN ?COMP RESOLVE-ORIG -COMP)
 
433
imm(ELSE ?COMP DOTICK DOBRANCH COMPILE, HERE 0 COMPILE, SWAP RESOLVE-ORIG)
 
434
 
 
435
imm(CASE +COMP 0)
 
436
imm(ENDCASE ?COMP DOTICK DROP COMPILE, ?DUP 0BRANCH(5) 1- SWAP THEN BRANCH(-8) -COMP)
 
437
imm(OF ?COMP 1+ >R DOTICK OVER COMPILE, DOTICK = COMPILE, IF DOTICK DROP COMPILE, R>)
 
438
imm(ENDOF ?COMP >R ELSE R>)
 
439
 
 
440
col(RESOLVE-DEST HERE CELL+ - COMPILE,)
 
441
imm(BEGIN +COMP HERE)
 
442
imm(AGAIN ?COMP DOTICK DOBRANCH COMPILE, RESOLVE-DEST -COMP)
 
443
imm(UNTIL ?COMP DOTICK DO0BRANCH COMPILE, RESOLVE-DEST -COMP)
 
444
imm(WHILE ?COMP IF SWAP)
 
445
imm(REPEAT ?COMP AGAIN THEN)
 
446
 
 
447
// Counted loops.
 
448
var(LEAVES 0)
 
449
col(RESOLVE-LOOP LEAVES @ ?DUP 0BRANCH(10) DUP @ SWAP HERE OVER - SWAP ! BRANCH(-13) HERE - COMPILE, LEAVES !)
 
450
imm(DO +COMP LEAVES @ HERE DOTICK DODO COMPILE, 0 LEAVES !)
 
451
imm(?DO +COMP LEAVES @ DOTICK DODO?DO COMPILE, HERE HERE LEAVES ! 0 COMPILE,)
 
452
imm(LOOP ?COMP DOTICK DODOLOOP COMPILE, RESOLVE-LOOP -COMP)
 
453
imm(+LOOP ?COMP DOTICK DODO+LOOP COMPILE, RESOLVE-LOOP -COMP)
 
454
imm(LEAVE ?COMP DOTICK DODOLEAVE COMPILE, LEAVES @ HERE LEAVES ! COMPILE,)
 
455
imm(?LEAVE ?COMP DOTICK DODO?LEAVE COMPILE, LEAVES @ HERE LEAVES ! COMPILE,)
 
456
 
 
457
// Interpreter nesting.
 
458
col(SAVE-SOURCE R> IB >R #IB @ >R SOURCE-ID >R SPAN @ >R >IN @ >R >R)
 
459
col(RESTORE-SOURCE R> R> >IN ! R> SPAN ! R> DOTO SOURCE-ID R> #IB ! R> DOTO IB >R)
 
460
 
 
461
// System replies.
 
462
str(OK-STR "ok")
 
463
str(ABORTED-STR "Aborted")
 
464
str(EXCEPTION-STR "Exception #")
 
465
str(UNKNOWN-STR "Undefined word")
 
466
dfr(HW-EXCEPTION-HANDLER)
 
467
val(SHOW-STACK? 0)
 
468
col(SHOWSTACK -1 DOTO  SHOW-STACK?)
 
469
col(NOSHOWSTACK 0 DOTO  SHOW-STACK?)
 
470
col(PRINT-STACK SHOW-STACK? 0BRANCH(5) >R >R .S R> R> )
 
471
col(PRINT-EXCEPTION DUP LIT(-99) = 0BRANCH(7) DOTICK UNKNOWN-STR COUNT TYPE CR DROP EXIT DUP LIT(0x100) = 0BRANCH(2) DROP EXIT HW-EXCEPTION-HANDLER )
 
472
col(PRINT-STATUS SPACE DUP 0= 0BRANCH(5) PRINT-STACK DOTICK OK-STR BRANCH(7) DUP -1 = 0BRANCH(6) DOTICK ABORTED-STR COUNT TYPE BRANCH(10) DUP LIT(-2) = 0BRANCH(7) ABORT"-STR @ COUNT TYPE DROP BRANCH(1) PRINT-EXCEPTION CR)
 
473
 
 
474
// The compiler and interpreter.
 
475
col(COMPILE-WORD 2DUP ($FIND) 0BRANCH(10) IMMEDIATE? 0BRANCH(4) NIP NIP EXECUTE EXIT COMPILE, 2DROP EXIT 2DUP $NUMBER 0BRANCH(4) TYPE LIT(-99) THROW DOTICK DOLIT COMPILE, COMPILE, 2DROP)
 
476
col(INTERPRET-WORD 2DUP ($FIND) 0BRANCH(5) DROP NIP NIP EXECUTE EXIT 2DUP $NUMBER 0BRANCH(4) TYPE LIT(-99) THROW >R 2DROP R>)
 
477
col(INTERPRET 0 >IN ! PARSE-WORD DUP 0BRANCH(10) STATE @ 0BRANCH(3) COMPILE-WORD BRANCH(1) INTERPRET-WORD BRANCH(-14) 2DROP)
 
478
 
 
479
// Evaluate, the one word to rule them all.  It is evil, btw.
 
480
col(EVALUATE SAVE-SOURCE -1 DOTO SOURCE-ID DUP #IB ! SPAN ! DOTO IB DOTICK INTERPRET CATCH RESTORE-SOURCE THROW)
 
481
col(EVAL EVALUATE)
 
482
 
 
483
// Abort with a message.
 
484
col(DOABORT" SWAP 0BRANCH(5) ABORT"-STR ! LIT(-2) THROW DROP)
 
485
imm(ABORT" C" DOTICK DOABORT" COMPILE,)
 
486
 
 
487
// Tick.
 
488
str(UNDEFINED-STR "undefined word ")
 
489
col(SET-UNDEFINED-WORD POCKET >R DOTICK UNDEFINED-STR DUP C@ 1+ R@ SWAP MOVE R@ DUP C@ 1+ + SWAP DUP R@ C@ + R@ C! MOVE R>)
 
490
col(' PARSE-WORD $FIND 0= 0BRANCH(4) SET-UNDEFINED-WORD TRUE SWAP DOABORT")
 
491
 
 
492
// The outer interpreter.
 
493
col(QUIT 0 RDEPTH! [ TERMINAL DEPTH . LIT('>') EMIT SPACE REFILL 0BRANCH(10) SPACE DOTICK INTERPRET CATCH DUP PRINT-STATUS 0BRANCH(-17) BRANCH(-23))
 
494
 
 
495
// Reading and writing to/from file; including files.
 
496
dfr(MAP-FILE)
 
497
dfr(UNMAP-FILE)
 
498
dfr(WRITE-FILE)
 
499
col(INCLUDED MAP-FILE 2DUP >R >R BOUNDS DO?DO(21) R> R@ SWAP >R R@ - R@ SWAP 2DUP LINEFEED FINDCHAR 0BRANCH(1) NIP DUP >R EVALUATE R> 1+ DO+LOOP(-21) R> R> UNMAP-FILE)
 
500
col(INCLUDE PARSE-WORD INCLUDED)
 
501
 
 
502
// CREATE ... DOES> ...
 
503
col($CREATE HEADER DOTICK DODOES COMPILE, DOTICK NOOP CELL+ COMPILE, REVEAL)
 
504
col(CREATE PARSE-WORD $CREATE)
 
505
col(DODOES> R> CELL+ LATEST @ LINK> CELL+ !)
 
506
imm(DOES> DOTICK DODOES> COMPILE,)
 
507
 
 
508
// Defining words.
 
509
col(CONSTANT PARSE-WORD HEADER DOTICK DOCON COMPILE, COMPILE, REVEAL)
 
510
col(VALUE PARSE-WORD HEADER DOTICK DOVAL COMPILE, COMPILE, REVEAL)
 
511
col(VARIABLE PARSE-WORD HEADER DOTICK DOVAR COMPILE, 0 COMPILE, REVEAL)
 
512
col(BUFFER: PARSE-WORD HEADER DOTICK DOBUFFER: COMPILE, ALLOT REVEAL)
 
513
col(DEFER PARSE-WORD HEADER DOTICK DODEFER COMPILE, DOTICK ABORT COMPILE, REVEAL)
 
514
col(ALIAS PARSE-WORD HEADER DOTICK DOALIAS COMPILE, ' COMPILE, REVEAL)
 
515
col(STRUCT 0)
 
516
col(END-STRUCT DROP)
 
517
col(FIELD PARSE-WORD HEADER DOTICK DOFIELD COMPILE, OVER , + REVEAL)
 
518
 
 
519
// Words with (mostly) non-standard compilation behaviour.
 
520
imm(LITERAL DOTICK DOLIT COMPILE, COMPILE,)
 
521
imm([COMPILE] ' COMPILE,)
 
522
imm(POSTPONE PARSE-WORD 2DUP ($FIND) 0= 0BRANCH(4) SET-UNDEFINED-WORD TRUE SWAP DOABORT" IMMEDIATE? 0= 0BRANCH(6) DOTICK DOTICK COMPILE, COMPILE, DOTICK COMPILE, COMPILE, 2DROP)
 
523
imm([CHAR] CHAR LITERAL)
 
524
imm(['] ' DOTICK DOTICK COMPILE, COMPILE,)
 
525
 
 
526
// FIND.
 
527
col(FIND DUP COUNT ($FIND) 0BRANCH(9) ROT DROP TRUE SWAP IMMEDIATE? 0BRANCH(1) NEGATE EXIT FALSE EXIT)
 
528
 
 
529
// Accessing data in CREATE'd words.
 
530
imm(TO ' STATE @ 0BRANCH(5) DOTICK DOTO COMPILE, COMPILE, EXIT CELL+ !)
 
531
col(BEHAVIOR CELL+ @)
 
532
col(>BODY 2 CELLS +)
 
533
col(BODY> 2 CELLS -)
 
534
 
 
535
// Making words recursive.
 
536
imm(RECURSIVE REVEAL)
 
537
imm(RECURSE LATEST @ LINK> COMPILE,)
 
538
 
 
539
// Numeric input.
 
540
imm(d# PARSE-WORD BASE @ >R DECIMAL EVALUATE R> BASE !)
 
541
imm(h# PARSE-WORD BASE @ >R HEX EVALUATE R> BASE !)
 
542
imm(o# PARSE-WORD BASE @ >R OCTAL EVALUATE R> BASE !)