/
muxleq.fth
1940 lines (1939 loc) · 76.6 KB
/
muxleq.fth
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
defined eforth [if] ' ) <ok> ! [then] ( Turn off ok prompt )
only forth definitions hex
1 constant opt.multi ( Add in large "pause" primitive )
1 constant opt.editor ( Add in Text Editor )
1 constant opt.info ( Add info printing function )
0 constant opt.generate-c ( Generate C code )
0 constant opt.better-see ( Replace 'see' with better version )
0 constant opt.control ( Add in more control structures )
0 constant opt.allocate ( Add in "allocate"/"free" )
0 constant opt.float ( Add in floating point code )
0 constant opt.glossary ( Add in "glossary" word )
0 constant opt.optimize ( Enable extra optimization )
1 constant opt.divmod ( Use "opDivMod" primitive )
0 constant opt.self ( self-interpreter [NOT WORKING] )
: sys.echo-off 1 or ; ( bit #1 = turn echoing chars off )
: sys.cksum 2 or ; ( bit #2 = turn checksumming on )
: sys.info 4 or ; ( bit #3 = print info msg on startup )
: sys.eof 8 or ; ( bit #4 = die if received EOF )
: sys.warnv $10 or ; ( bit #5 = warn if virtualized )
0 ( sys.cksum ) sys.eof sys.echo-off
sys.warnv constant opt.sys
defined (order) 0= [if]
: (order) ( w wid*n n -- wid*n w n )
dup if
1- swap >r recurse over r@ xor
if 1+ r> -rot exit then rdrop
then ;
: -order get-order (order) nip set-order ; ( wid -- )
: +order dup >r -order get-order r> swap 1+ set-order ;
[then]
defined [unless] 0= [if]
: [unless] 0= postpone [if] ; immediate
[then]
defined eforth [if]
: wordlist here cell allot 0 over ! ; ( -- wid : alloc wid )
[then]
wordlist constant meta.1 ( meta-compiler word set )
wordlist constant target.1 ( target eForth word set )
wordlist constant assembler.1 ( assembler word set )
wordlist constant target.only.1 ( target only word set )
defined eforth [if] system +order [then]
meta.1 +order definitions
2 constant =cell \ Target cell size
4000 constant size \ Size of image working area
100 constant =buf \ Size of text input buffers in target
100 constant =stksz \ Size of return and variable stacks
FC00 constant =thread \ Initial start of thread area
0008 constant =bksp \ Backspace character value
000A constant =lf \ Line feed character value
000D constant =cr \ Carriage Return character value
007F constant =del \ Delete character
create tflash tflash size cells allot size erase
variable tzreg 0 tzreg !
variable tareg 1 tareg !
variable tdp 0 tdp ! ( target dictionary pointer )
variable tlast 0 tlast ! ( last defined target word pointer )
variable tlocal 0 tlocal ! ( local variable allocator )
variable voc-last 0 voc-last ! ( last defined in any vocab )
: :m meta.1 +order definitions : ; ( --, "name" )
: ;m postpone ; ; immediate ( -- )
:m tcell 2 ;m ( -- 2 : bytes in a target cell )
:m there tdp @ ;m ( -- a : target dictionary pointer value )
:m tc! tflash + c! ;m ( c a -- : target write char )
:m tc@ tflash + c@ ;m ( a -- c : target get char )
:m t! over FF and over tc! swap 8 rshift swap 1+ tc! ;m
:m t@ dup tc@ swap 1+ tc@ 8 lshift or ;m ( a -- u : target @ )
:m taligned dup 1 and + ;m ( u -- u : align target pointer )
:m talign there 1 and tdp +! ;m ( -- : align target dic. ptr. )
:m tc, there tc! 1 tdp +! ;m ( c -- : write char to targ. dic.)
:m t, there t! 2 tdp +! ;m ( u -- : write cell to target dic. )
:m tallot tdp +! ;m ( u -- : allocate bytes in target dic. )
:m mdrop drop ;m ( u -- : always call drop )
:m mswap swap ;m ( u -- : always call swap )
:m mdecimal decimal ;m ( -- : always call decimal )
:m mhex hex ;m ( -- : always call hex )
defined eforth [if]
:m tpack dup tc, for aft count tc, then next drop ;m
:m parse-word bl word ?nul count ;m ( -- a u )
:m limit ;m ( u -- u16 : not needed on 16-bit systems )
[else]
:m tpack talign dup tc, 0 ?do count tc, loop drop ;m
:m limit FFFF and ;m ( u -- u16 : limit variable to 16 bits )
[then]
:m $literal talign [char] " word count tpack talign ;m
defined eforth [if]
:m #dec s>d if [char] - emit then (.) ;m ( n16 -- )
[else]
:m #dec dup 8000 u>= if negate limit -1 >r else 0 >r then
0 <# #s r> sign #> type ;m ( n16 -- )
[then]
opt.generate-c [if]
:m msep 2C emit ;m ( -- : emit "," as separator )
[else]
:m msep A emit ;m ( -- : emit space as separator )
[then]
:m mdump taligned ( a u -- )
begin ?dup
while swap dup @ limit #dec msep tcell + swap tcell -
repeat drop ;m
:m save-target decimal tflash there mdump ;m ( -- )
:m .end only forth definitions decimal ;m ( -- )
:m atlast tlast @ ;m ( -- a : meta-comp last defined word )
:m local? tlocal @ ;m ( -- u : meta-comp local offset )
:m lallot >r tlocal @ r> + tlocal ! ;m ( u -- allot in target )
:m tuser ( --, "name", Created-Word: -- u )
get-current >r meta.1 set-current create r>
set-current tlocal @ =cell lallot , does> @ ;m
:m tvar get-current >r ( --, "name", Created-Word: -- a )
meta.1 set-current create
r> set-current there , t, does> @ ;m
:m label: get-current >r ( --, "name", Created-Word: -- a )
meta.1 set-current create
r> set-current there , does> @ ;m
:m tdown =cell negate and ;m ( a -- a : align down )
:m tnfa =cell + ;m ( pwd -- nfa : move to name field address )
:m tcfa tnfa dup c@ 1F and + =cell + tdown ;m ( pwd -- cfa )
:m compile-only voc-last @ tnfa t@ 20 or voc-last @ tnfa t! ;m
:m immediate voc-last @ tnfa t@ 40 or voc-last @ tnfa t! ;m
:m half dup 1 and abort" unaligned" 2/ ;m ( a -- a : meta 2/ )
:m double 2* ;m ( a -- a : meta-comp 2* )
defined eforth [if]
:m (') bl word find ?found cfa ;m
:m t' (') >body @ ;m ( --, "name" )
:m to' target.only.1 +order (') >body @ target.only.1 -order ;m
[else]
:m t' ' >body @ ;m ( --, "name" )
:m to' target.only.1 +order ' >body @ target.only.1 -order ;m
[then]
:m tcompile to' half t, ;m
:m >tbody =cell + ;m
:m tcksum taligned dup C0DE - FFFF and >r
begin ?dup
while swap dup t@ r> + FFFF and >r =cell + swap =cell -
repeat drop r> ;m ( a u -- u : compute a checksum )
:m mkck dup there swap - tcksum ;m ( -- u : checksum of image )
:m postpone ( --, "name" )
target.only.1 +order t' target.only.1 -order 2/ t, ;m
:m thead talign there tlast @ t, dup tlast ! voc-last !
parse-word talign tpack talign ;m ( --, "name" )
:m header >in @ thead >in ! ;m ( --, "name" )
:m :ht ( "name" -- : forth routine, no header )
get-current >r target.1 set-current create
r> set-current CAFE talign there ,
does> @ 2/ t, ;m
:m :t header :ht ;m ( "name" -- : forth routine )
:m :to ( "name" -- : forth, target only routine )
header
get-current >r
target.only.1 set-current create
r> set-current
CAFE talign there ,
does> @ 2/ t, ;m
:m :a ( "name" -- : assembly routine, no header )
1234 target.1 +order definitions
create talign there , assembler.1 +order does> @ 2/ t, ;m
:m (fall-through); 1234 <>
if abort" unstructured" then assembler.1 -order ;m
:m (a); (fall-through); ;m
defined eforth [if] system -order [then]
:m Z tzreg @ t, ;m ( -- : Address 0 must contain 0 )
:m A, Z ;m ( -- : Synonym for 'Z', temporary location )
:m V, tareg @ t, ;m ( -- : Address 1 also contains 0, tmp loc )
:m NADDR there 2/ 1+ t, ;m ( --, jump to next cell )
:m HALT Z Z -1 t, ;m ( --, Halt but do not catch fire )
:m JMP 2/ Z Z t, ;m ( a --, Jump to location )
:m ADD swap 2/ t, Z NADDR Z 2/ t, NADDR Z Z NADDR ;m
:m SUB swap 2/ t, 2/ t, NADDR ;m ( a a -- : subtract )
:m NOOP Z Z NADDR ;m ( -- : No operation )
:m ZERO dup 2/ t, 2/ t, NADDR ;m ( a -- : zero a location )
:m PUT 2/ t, -1 t, NADDR ;m ( a -- : put a byte )
:m GET 2/ -1 t, t, NADDR ;m ( a -- : get a byte )
assembler.1 +order definitions
: begin talign there ; ( -- a )
: again JMP ; ( a -- )
: mark there 0 t, ; ( -- a : create hole in dictionary )
: if talign ( a -- a : NB. "if" does not work for $8000 )
2/ dup t, Z there 2/ 4 + dup t, Z Z 6 + t, Z Z NADDR Z t,
mark ;
: until 2/ dup t, Z there 2/ 4 + dup t, Z Z 6 + t,
Z Z NADDR Z t, 2/ t, ; ( a -- a )
: else talign Z Z mark swap there 2/ swap t! ; ( a -- a )
: +if talign Z 2/ t, mark ; ( a -- a )
: -if talign
2/ t, Z there 2/ 4 + t, Z Z there 2/ 4 + t, Z Z mark ;
: then begin 2/ swap t! ; ( a -- )
: while if swap ; ( a a -- a a )
: repeat JMP then ; ( a a -- )
assembler.1 -order
meta.1 +order definitions
0 t, 0 t, \ both locations must be zero
label: entry \ used to set entry point in next cell
-1 t, \ system entry point, set later
opt.sys tvar {options} \ bit #1=echo off, #2 = checksum on,
\ #4=info, #8=die on EOF
0 tvar primitive \ any address lower must be a VM primitive
=stksz half tvar stacksz \ must contain $80
0 tvar zreg \ must contain 0
-1 tvar neg1 \ must contain -1
1 tvar one \ must contain 1
$10 tvar bwidth \ must contain 16
$40 tvar mwidth \ maximum machine width
0 tvar r0 \ working pointer 1 (register r0)
0 tvar r1 \ register 1
0 tvar r2 \ register 2
0 tvar r3 \ register 3
0 tvar r4 \ register 4
opt.self [if]
0 tvar {virtual} \ are we virtualized?
0 tvar {self} \ location of the self interpreter
0 tvar {pc} \ Emulated SUBLEQ Machine program counter
$10 tvar {width} \ set by size detection routines
[then]
0 tvar h \ dictionary pointer
=thread half tvar {up} \ Current task addr. (Half size)
0 tvar check \ used for system checksum
0 tvar {context} E tallot \ vocabulary context
0 tvar {current} \ vocabulary to add new definitions to
0 tvar {forth-wordlist} \ forth word list (main vocabulary)
0 tvar {editor} \ editor vocabulary
0 tvar {root-voc} \ absolute minimum vocabulary
0 tvar {system} \ system functions vocabulary
0 tvar {cold} \ entry point of VM program, set later on
0 tvar {last} \ last defined word
0 tvar {cycles} \ number of times we have switched tasks
1 tvar {single} \ is multi processing off? +ve = off
0 tvar {user} \ Number of locals assigned
\ Thread variables, not all of which are user variables
0 tvar ip \ instruction pointer
0 tvar tos \ top of stack
=thread =stksz + half dup tvar {rp0} tvar {rp}
=thread =stksz double + half dup tvar {sp0} tvar {sp}
200 constant =tib \ Start of terminal input buffer
380 constant =num \ Start of numeric input buffer
tuser {next-task} \ next task in task list
tuser {ip-save} \ saved instruction pointer
tuser {tos-save} \ saved top of variable stack
tuser {rp-save} \ saved return stack pointer
tuser {sp-save} \ saved variable stack pointer
tuser {handler} \ throw/catch handler
tuser {sender} \ multitasking; msg. send, 0 = no message
tuser {message} \ multitasking; the message itself
tuser {id} \ executing from block or terminal?
tuser {precision} \ floating point precision (if FP on)
:m INC 2/ neg1 2/ t, t, NADDR ;m ( b -- )
:m DEC 2/ one 2/ t, t, NADDR ;m ( b -- )
:m MUXR >r 2/ t, 2/ t, r> 2/ $8000 or t, ;m
:m MMOV swap zreg MUXR ;m ( a a -- )
:m -MMOV swap neg1 MUXR ;m ( a a -- )
:m iJMP there 2/ 5 + 2* MMOV Z Z NADDR ;m ( a -- )
:m ONE! one swap MMOV ;m ( a -- : set address to '1' )
:m NG1! neg1 swap MMOV ;m ( a -- : set address to '-1' )
:m iSTORE there 4 2* + MMOV 0 MMOV ;m ( a a -- )
:m iLOAD there 3 2* + MMOV 0 swap MMOV ;m
:m iADD ( a a -- : indirect add )
2/ t, A, NADDR
2/ t, V, NADDR
there 2/ 7 + dup dup t, t, NADDR
A, t, NADDR
V, 0 t, NADDR
A, A, NADDR
V, V, NADDR ;m
:m iSUB ( a a -- : indirect sub )
2/ t, A, NADDR
2/ >r
there 2/ 7 + dup dup t, t, NADDR
A, t, NADDR
r> t, 0 t, NADDR
A, A, NADDR ;m
:m ++sp {sp} DEC ;m ( -- : grow variable stack )
:m --sp {sp} INC ;m ( -- : shrink variable stack )
:m --rp {rp} DEC ;m ( -- : shrink return stack )
:m ++rp {rp} INC ;m ( -- : grow return stack )
opt.optimize [if] ( optimizations on )
:m a-optim 2/ >r there =cell - r> swap t! ;m ( a -- )
[else]
:m a-optim drop ;m ( a -- : optimization off )
[then]
( Error message string "Error: Not a 16-bit SUBLEQ VM" )
45 tvar err-str
72 t, 72 t, 6F t, 72 t, 3A t, 20 t, 4E t,
6F t, 74 t, 20 t, 61 t, 20 t, 31 t, 36 t, 2D t,
62 t, 69 t, 74 t, 20 t, 53 t, 55 t, 42 t, 4C t,
45 t, 51 t, 20 t, 56 t, 4D t, 0D t, 0A t, -1 t,
err-str 2/ tvar err-str-addr
assembler.1 +order
label: die
err-str-addr r0 MMOV ( load string address )
label: die.loop
r1 r0 iLOAD ( load character )
r0 INC ( increment to next cell )
r1 +if
r1 PUT ( output single byte )
die.loop JMP ( sentinel is a negative val )
then
( fall-through )
:a bye ( -- : first VM word, "bye", or halt the Forth system )
HALT (a); ( ...like tears in rain. Time to die. )
assembler.1 +order
label: start \ System Entry Point
start 2/ entry t! \ Set the system entry point
r0 ONE! \ r0 = shift bit loop count
r1 ONE! \ r1 = number of bits
label: chk16
r0 r0 ADD \ r0 = r0 * 2
r1 INC \ r1++
r1 r2 MMOV \ r2 = r1
mwidth r2 SUB r2 +if die JMP then \ check length < max width
r0 +if chk16 JMP then \ check if still positive
opt.self [if] \ if width > 16, jump to 16-bit emulator
r1 r2 MMOV
r1 {width} MMOV \ Save actual machine width
bwidth r2 SUB r2 +if {self} iJMP then
[then]
bwidth r1 SUB r1 if die JMP then \ r1 - bwidth should be 0
opt.self [if] ( self JMP ) there 2/ {pc} t! [then]
{sp0} {sp} MMOV \ Setup initial variable stack
{rp0} {rp} MMOV \ Setup initial return stack
{cold} ip MMOV \ Get the first instruction to execute
( fall-through )
label: vm ( Forth Inner Interpreter )
r0 ip iLOAD \ Get instruction to execute from IP
ip INC \ IP now points to next instruction!
primitive r1 MMOV \ Copy as SUB is destructive
r0 r1 SUB \ Check if it is a primitive
r1 +if r0 iJMP then \ Jump straight to VM functions if it is
++rp \ If it wasn't a VM instruction, inc {rp}
ip {rp} iSTORE \ and store ip to return stack
r0 ip MMOV \ "r0" holds our next instruction
vm JMP \ Ad infinitum...
:m ;a (fall-through); vm JMP ;m
opt.self [if]
\ THIS NEEDS REWORKING FOR MUXLEQ
0 tvar {zreg} {zreg} 2/ tzreg !
0 tvar {areg} {areg} 2/ tareg !
0000 tvar {a} ( Emulated 'a' operand )
0000 tvar {b} ( Emulated 'b' operand )
0000 tvar {v} ( Temporary register 'v' )
-0010 tvar {count} ( Top bit count, modified later )
label: self
self 2/ {self} t!
{virtual} NG1!
{width} {count} ADD
label: self-loop
{pc} {v} MMOV \ Copy {pc} for next instruction
neg1 2/ t, {v} 2/ t, -1 t, \ Conditionally halt on '{c}'
{a} {pc} iLOAD {pc} INC
{b} {pc} iLOAD {pc} INC
{a} {v} MMOV {v} INC {v} +if ( Input byte? )
{b} {v} MMOV {v} INC {v} +if ( Output byte? )
( Neither Input nor Output, must be normal instruction )
\ This section performs "m[b] = m[b] - m[a]" and loads
\ the result back into "{a}". A custom "iSUB" routine
\ might speed things up here, one that stored the result
\ in "{b}" but also kept a copy in "{a}".
{a} {a} iLOAD \ a = m[a]
{a} {b} iSUB \ m[b] = m[b] - a
{a} {b} iLOAD \ a = m[b]
\ This section prepares "{a}" for the next "+if", it
\ shifts the 16-bit into the top place depending on the
\ machine width. The bits lower than the 16-bit do not
\ matter unless they are all zero, in which case this
\ shifting has no effect anyway.
{count} {v} MMOV
label: self.bit
{a} {a} ADD {v} DEC
{v} +if self.bit JMP then
{a} +if \ !(v == 0 || v & 0x8000)
{pc} INC
self-loop JMP
then
{pc} {pc} iLOAD \ pc = m[c]
self-loop JMP
then ( Output byte from m[a] )
{a} {a} iLOAD
{a} PUT
{pc} INC
self-loop JMP
then ( Input byte and store in m[b] )
{a} GET
{a} {b} iSTORE
{pc} INC
self-loop JMP ( And do it again... )
0 tzreg !
1 tareg !
[then]
assembler.1 -order
:a opSwap tos r0 MMOV tos {sp} iLOAD r0 {sp} iSTORE ;a
:a opDup ++sp tos {sp} iSTORE ;a ( n -- n n )
:a opFromR ++sp tos {sp} iSTORE tos {rp} iLOAD --rp ;a
:a opToR ++rp tos {rp} iSTORE (fall-through); ( !!! )
:a opDrop tos {sp} iLOAD --sp ;a ( n -- )
:a [@] tos tos iLOAD ;a ( a -- a : load SUBLEQ address )
:a [!] r0 {sp} iLOAD r0 tos iSTORE --sp t' opDrop JMP (a);
:a opEmit tos PUT t' opDrop JMP (a); ( n -- )
:a opExit ip {rp} iLOAD (fall-through); ( !!! ) ( R: a -- )
:a rdrop --rp ;a ( R: u -- )
:a opIpInc ip INC ;a ( -- : increment instruction pointer )
:a opJumpZ ( u -- : Conditional jump on zero )
tos r0 MMOV
tos {sp} iLOAD --sp
r0 if t' opIpInc JMP then r0 DEC r0 +if t' opIpInc JMP then
(fall-through); ( !!! )
:a opJump ip ip iLOAD ;a ( -- : Unconditional jump )
:a opNext r0 {rp} iLOAD ( R: n -- | n-1 )
r0 +if r0 DEC r0 {rp} iSTORE t' opJump JMP then
--rp t' opIpInc JMP (a);
:a op0= ( n -- f : not equal to zero )
( does not work: "tos if tos ZERO else tos NG1! then vm JMP" )
tos if ( assembly 'if' does not work for entire range )
tos ZERO
else ( deal with incorrect results )
tos DEC
tos +if tos ZERO else tos NG1! then
then ;a
:a leq0 ( n -- 0|1 : less than or equal to zero )
Z tos 2/ t, there 2/ 4 + t,
tos 2/ dup t, t, vm 2/ t,
tos ONE! ;a
:a - tos {sp} iSUB t' opDrop JMP (a); ( n n -- n )
:a + tos {sp} iADD t' opDrop JMP (a); ( n n -- n )
:a shift ( u n -- u : right shift 'u' by 'n' places )
bwidth r0 MMOV \ load machine bit width
tos r0 SUB \ adjust tos by machine width
tos {sp} iLOAD --sp \ pop value to shift
r1 ZERO \ zero result register
label: shift.loop
r1 r1 ADD \ double r1, equivalent to left shift by one
\ work out what bit to shift into r1
tos +if else
tos r2 MMOV r2 INC r2 +if else r1 INC then then
tos tos ADD \ double tos, equivalent to left shift by one
r0 DEC \ decrement loop counter
r0 +if shift.loop JMP then
r1 tos MMOV ;a \ move result back into tos
:a opGet ( -- char )
++sp tos {sp} iSTORE
tos GET ;a
\ :a opPush
\ ++sp tos {sp} iSTORE
\ tos ip iLOAD
\ ip INC ;a
:a opMux ( u1 u2 u3 -- u : bitwise multiplexor function )
r4 {sp} iLOAD --sp \ pop first input
r3 {sp} iLOAD --sp \ pop second input
r3 r4 tos MUXR
r3 tos MMOV ;a
opt.divmod [if]
:a opDivMod ( u1 u2 -- u1 u2 )
r0 {sp} iLOAD
r1 ZERO ( zero quotient )
label: divStep
r1 INC ( increment quotient )
tos r0 SUB ( repeated subtraction )
r0 -if
tos r0 ADD ( correct remainder )
r1 DEC ( correct quotient )
r1 tos MMOV ( store results back to tos )
r0 {sp} iSTORE ( ...and stack )
vm JMP ( finish... )
then
divStep JMP ( perform another division step )
(a);
[then]
opt.multi [if]
:a pause ( -- : pause and switch task )
\ "{single}" must be positive and not zero to
\ turn off "pause", this is to save space as "+if" can be
\ used.
{single} +if vm JMP then \ Do nothing if single-threaded mode
r0 {up} iLOAD \ load next task pointer from user storage
\ "+if" saves space, "r0" should never be negative anyway as
\ this would mean that the thread was above the 32678 mark
\ and thus in an area where "@" and "!" would not work (only
\ "[@]" and "[!]".
r0 +if
{cycles} INC \ increment "pause" count
{up} r1 MMOV r1 INC \ load TASK pointer, skip next task
ip r1 iSTORE r1 INC \ save registers to current task
tos r1 iSTORE r1 INC \ only a few need to be saved
{rp} r1 iSTORE r1 INC
{sp} r1 iSTORE
r0 {rp0} MMOV stacksz {rp0} ADD \ change {rp0} to new loc
{rp0} {sp0} MMOV stacksz {sp0} ADD \ same but for {sp0}
r0 {up} MMOV r0 INC \ set next task
ip r0 iLOAD r0 INC \ reverse of save registers
tos r0 iLOAD r0 INC
{rp} r0 iLOAD r0 INC
{sp} r0 iLOAD \ we're all golden
then ;a
[else]
:m pause ;m ( -- [disabled] )
[then]
there 2/ primitive t! ( set 'primitive', needed for VM )
:m munorder target.only.1 -order talign ;m
:m (;t)
CAFE <> if abort" Unstructured" then
munorder ;m
:m ;t (;t) opExit ;m
:m :s tlast @ {system} t@ tlast ! F00D :t drop 0 ;m
:m :so tlast @ {system} t@ tlast ! F00D :to drop 0 ;m
:m ;s drop CAFE ;t F00D <> if abort" unstructured" then
tlast @ {system} t! tlast ! ;m
:m :r tlast @ {root-voc} t@ tlast ! BEEF :t drop 0 ;m
:m ;r drop CAFE ;t BEEF <> if abort" unstructured" then
tlast @ {root-voc} t! tlast ! ;m
:m :e tlast @ {editor} t@ tlast ! DEAD :t drop 0 ;m
:m ;e drop CAFE ;t DEAD <> if abort" unstructured" then
tlast @ {editor} t! tlast ! ;m
:m system[ tlast @ {system} t@ tlast ! BABE ;m
:m ]system BABE <> if abort" unstructured" then
tlast @ {system} t! tlast ! ;m
:m root[ tlast @ {root-voc} t@ tlast ! D00D ;m
:m ]root D00D <> if abort" unstructured" then
tlast @ {root-voc} t! tlast ! ;m
:m : :t ;m ( -- ???, "name" : start cross-compilation )
:m ; ;t ;m ( ??? -- : end cross-compilation of a target word )
:m begin talign there ;m ( -- a : meta 'begin' )
:m until talign opJumpZ 2/ t, ;m ( a -- : meta 'until' )
:m again talign opJump 2/ t, ;m ( a -- : meta 'again' )
:m if opJumpZ there 0 t, ;m ( -- a : meta 'if' )
:m tmark opJump there 0 t, ;m ( -- a : meta mark location )
:m then there 2/ swap t! ;m ( a -- : meta 'then' )
:m else tmark swap then ;m ( a -- a : meta 'else' )
:m while if ;m ( -- a : meta 'while' )
:m repeat swap again then ;m ( a a -- : meta 'repeat' )
:m aft drop tmark begin swap ;m ( a -- a a : meta 'aft' )
:m next talign opNext 2/ t, ;m ( a -- : meta 'next' )
:m for opToR begin ;m ( -- a : meta 'for )
:m =jump [ t' opJump half ] literal ;m ( -- a )
:m =jumpz [ t' opJumpZ half ] literal ;m ( -- a )
:m =unnest [ t' opExit half ] literal ;m ( -- a )
:m =>r [ t' opToR half ] literal ;m ( -- a )
:m =next [ t' opNext half ] literal ;m ( -- a )
:m dup opDup ;m ( -- : compile opDup into the dictionary )
:m drop opDrop ;m ( -- : compile opDrop into the dictionary )
:m swap opSwap ;m ( -- : compile opSwap into the dictionary )
:m >r opToR ;m ( -- : compile opTorR into the dictionary )
:m r> opFromR ;m ( -- : compile opFromR into the dictionary )
:m 0= op0= ;m ( -- : compile op0= into the dictionary )
:m mux opMux ;m ( -- : compile opMux into the dictionary )
:m exit opExit ;m ( -- : compile opExit into the dictionary )
:m rshift shift ;m ( -- : compile shift into the dictionary )
:to + + ; ( n n -- n : addition )
:to - - ; ( n1 n2 -- n : subtract n2 from n1 )
:to bye bye ; ( -- : halt the system )
:to dup dup ; ( n -- n n : duplicate top of variable stack )
:to drop opDrop ; ( n -- : drop top of variable stack )
:to swap opSwap ; ( x y -- y x : swap two variables on stack )
:to rshift shift ; ( u n -- u : logical right shift by "n" )
:so [@] [@] ;s ( vma -- : fetch -VM Address- )
:so [!] [!] ;s ( u vma -- : store to -VM Address- )
:to 0= op0= ; ( n -- f : equal to zero )
:so leq0 leq0 ;s ( n -- 0|1 : less than or equal to zero )
:so mux opMux ;s ( u1 u2 sel -- u : bitwise multiplex op. )
:so pause pause ;s ( -- : pause current task, task switch )
: 2* dup + ; ( u -- u : multiply by two )
:s (const) r> [@] ;s compile-only ( R: a --, -- u )
:m constant :t mdrop (const) t, munorder ;m
system[
0 constant #0 ( -- 0 : push the number zero onto the stack )
1 constant #1 ( -- 1 : push one onto the stack )
-1 constant #-1 ( -- -1 : push negative one onto the stack )
2 constant #2 ( -- 2 : push two onto the stack )
-2 constant -cell ( -- -2 : push negative two onto the stack )
]system
: 1+ #1 + ; ( n -- n : increment value in cell )
: 1- #1 - ; ( n -- n : decrement value in cell )
:s (push) r> dup [@] swap 1+ >r ;s ( -- n : inline push value )
:m lit (push) t, ;m ( n -- : compile a literal )
:m literal lit ;m ( n -- : synonym for "lit" )
:m ] ;m ( -- : meta-compiler version of "]", do nothing )
:m [ ;m ( -- : meta-compiler version of "[", do nothing )
:s (up) r> dup [@] [ {up} half ] literal [@] 2* + swap 1+ >r ;s
compile-only ( -- n : user variable implementation word )
:s (var) r> 2* ;s compile-only ( R: a --, -- a )
:s (user) r> [@] [ {up} half ] literal [@] 2* + ;s compile-only
( R: a --, -- u )
:m up (up) t, ;m ( n -- : compile user variable )
:m [char] char (push) t, ;m ( --, "name" : compile char )
:m char char (push) t, ;m ( --, "name" : compile char )
:m variable :t mdrop (var) 0 t, munorder ;m ( --, "name": var )
:m user :t mdrop (user) local? =cell lallot t, munorder ;m
:to ) ; immediate ( -- : NOP, terminate comment )
: over swap dup >r swap r> ; ( n1 n2 -- n1 n2 n1 )
: invert #-1 swap - ; ( u -- u : bitwise invert )
: xor >r dup invert swap r> mux ; ( u u -- u : bitwise xor )
: or over mux ; ( u u -- u : bitwise or )
: and #0 swap mux ; ( u u -- u : bitwise and )
: 2/ #1 rshift ; ( u -- u : divide by two )
: @ 2/ [@] ; ( a -- u : fetch a cell to a memory location )
: ! 2/ [!] ; ( u a -- : write a cell to a memory location )
:s @+ dup @ ;s ( a -- a u : non-destructive load )
user <ok> ( -- a : okay prompt xt loc. )
system[
user <emit> ( -- a : emit xt loc. )
user <key> ( -- a : key xt loc. )
user <echo> ( -- a : echo xt loc. )
user <literal> ( -- a : literal xt loc. )
user <tap> ( -- a : tap xt loc. )
user <expect> ( -- a : expect xt loc. )
user <error> ( -- a : <error> xt container. )
]system
:s <cold> [ {cold} ] literal ;s ( -- a : cold xt loc. )
: current ( -- a : get current vocabulary )
[ {current} ] literal ;
: root-voc ( -- a : get root vocabulary )
[ {root-voc} ] literal ;
: this [ 0 ] up ; ( -- a : address of task thread memory )
: pad this [ 3C0 ] literal + ; ( -- a : index into pad area )
8 constant #vocs ( -- u : number of vocabularies )
: context [ {context} ] literal ; ( -- a )
variable blk ( -- a : loaded block )
variable scr ( -- a : latest listed block )
2F t' scr >tbody t! ( Set default block to list, an empty one )
user base ( -- a : push the radix for numeric I/O )
user dpl ( -- a : decimal point variable )
user hld ( -- a : index to hold space for num. I/O)
user state ( -- f : interpreter state )
user >in ( -- a : input buffer position var )
user span ( -- a : number of chars saved by expect )
$20 constant bl ( -- 32 : push space character )
system[
h constant h? ( -- a : push the location of dict. ptr )
{cycles} constant cycles ( -- a : number of "cycles" ran for )
{sp} constant sp ( -- a : address of v.stk ptr. )
{user} constant user? ( -- a : address of user alloc var )
variable calibration 1400 t' calibration >tbody t!
]system
:s radix base @ ;s ( -- u : retrieve base )
: here h? @ ; ( -- u : push the dictionary pointer )
: sp@ sp @ 1+ ; ( -- a : Fetch variable stack pointer )
: sp! 1- [ {sp} half ] literal [!] #1 drop ;
: rp@ [ {rp} half ] literal [@] 1- ; compile-only
: rp! r> swap [ {rp} half ] literal [!] >r ; compile-only
: hex [ $10 ] literal base ! ; ( -- : hexadecimal base )
: decimal [ $A ] literal base ! ; ( -- : decimal base )
:to ] #-1 state ! ; ( -- : return to compile mode )
:to [ #0 state ! ; immediate ( -- : initiate command mode )
: nip swap drop ; ( x y -- y : remove second item on stack )
: tuck swap over ; ( x y -- y x y : save item for rainy day )
: ?dup dup if dup then ; ( x -- x x | 0 : conditional dup )
: r@ r> r> tuck >r >r ; compile-only ( R: n -- n, -- n )
: rot >r swap r> swap ; ( x y z -- y z x : "rotate" stack )
: -rot rot rot ; ( x y z -- z x y : "rotate" stack backwards )
: 2drop drop drop ; ( x x -- : drop it like it is hot )
: 2dup over over ; ( x y -- x y x y )
:s shed rot drop ;s ( x y z -- y z : drop third stack item )
: = - 0= ; ( u1 u2 -- f : equality )
: <> = 0= ; ( u1 u2 -- f : inequality )
: 0> leq0 0= ; ( n -- f : greater than zero )
: 0<> 0= 0= ; ( n -- f : not equal to zero )
: 0<= 0> 0= ; ( n -- f : less than or equal to zero )
: < ( n1 n2 -- f : less than, is n1 less than n2 )
2dup leq0 swap leq0 if
if
2dup 1+ leq0 swap 1+ leq0
if drop else if 2drop #0 exit then then
else 2drop #-1 exit then \ a0 && !b0
else
if 2drop #0 exit then \ !a0 && b0
then
2dup - leq0 if
swap 1+ swap - leq0 if #-1 exit then
#0 exit
then
2drop #0 ;
: > swap < ; ( n1 n2 -- f : signed greater than )
: 0< #0 < ; ( n -- f : less than zero )
: 0>= 0< 0= ; ( n1 n2 -- f : greater or equal to zero )
: >= < 0= ; ( n1 n2 -- f : greater than or equal to )
: <= > 0= ; ( n1 n2 -- f : less than or equal to )
: u< 2dup 0>= swap 0>= <> >r < r> <> ; ( u1 u2 -- f )
: u> swap u< ; ( u1 u2 -- f : unsigned greater than )
: u>= u< 0= ; ( u1 u2 -- f : unsigned greater or equal to )
: u<= u> 0= ; ( u1 u2 -- f : unsigned less than or equal to )
: within over - >r - r> u< ; ( u lo hi -- f )
: negate 1- invert ; ( n -- n : twos compliment negation )
: s>d dup 0< ; ( n -- d : signed to double width cell )
: abs s>d if negate then ; ( n -- u : absolute value )
2 constant cell ( -- u : push bytes in cells to stack )
: cell+ cell + ; ( a -- a : increment address by cell width )
: cells 2* ; ( u -- u : multiply # of cells to get bytes )
: cell- cell - ; ( a -- a : decrement address by cell width )
: execute 2/ >r ; ( xt -- : execute an execution token )
:s @execute ( ?dup 0= ?exit ) @ execute ;s ( xt -- )
: ?exit if rdrop then ; compile-only ( u --, R: -- |??? )
: key? pause opGet ( -- c 0 | -1 : get byte of input )
s>d if
[ {options} ] literal @
[ 8 ] literal and if bye then drop #0 exit
then #-1 ;
: key begin <key> @execute until ; ( -- c )
: emit <emit> @execute ; ( c -- : output byte )
: cr ( -- : emit new line )
[ =cr ] literal emit
[ =lf ] literal emit ;
: get-current current @ ; ( -- wid : get definitions vocab. )
: set-current current ! ; ( -- wid : set definitions vocab. )
:s last get-current @ ;s ( -- wid : get last defined word )
: pick sp@ + [@] ; ( nu...n0 u -- nu : pick item on stack )
: +! 2/ tuck [@] + swap [!] ; ( u a -- : add val to cell )
: lshift negate shift ; ( u n -- u : left shift 'u' by 'n' )
: c@ ( a -- c : character load )
@+ swap #1 and if
[ 8 ] literal rshift exit
then [ FF ] literal and ;
: c! swap [ FF ] literal and dup [ 8 ] literal lshift or swap
tuck @+ swap #1 and 0= [ FF ] literal xor
>r over xor r> and xor swap ! ; ( c a -- character store )
:s c@+ dup c@ ;s ( b -- b u : non-destructive 'c@' )
: max 2dup > mux ; ( n1 n2 -- n : highest of two numbers )
: min 2dup < mux ; ( n1 n2 -- n : lowest of two numbers )
: source-id [ {id} ] up @ ; ( -- u : input type )
: 2! tuck ! cell+ ! ; ( u1 u2 a -- : store two cells )
: 2@ dup cell+ @ swap @ ; ( a -- u1 u2 : fetch two cells )
: 2>r r> swap >r swap >r >r ; compile-only ( n n --,R: -- n n )
: 2r> r> r> swap r> swap >r ; compile-only ( -- n n,R: n n -- )
system[ user tup =cell tallot ]system
: source tup 2@ ; ( -- a u : get terminal input source )
: aligned dup #1 and 0<> #1 and + ; ( u -- u : align up ptr. )
: align here aligned h? ! ; ( -- : align up dict. ptr. )
: allot h? +! ; ( n -- : allocate space in dictionary )
: , align here ! cell allot ; ( u -- : write value into dict. )
: c, here c! #1 allot ; ( c -- : write character into dict. )
: count dup 1+ swap c@ ; ( b -- b c : advance string )
: +string #1 over min rot over + -rot - ; ( b u -- b u )
:s .emit ( c -- : print char, replacing non-graphic ones )
dup bl [ $7F ] literal within [char] . swap mux emit ;s
: type 1- for count emit next drop ;
: cmove ( b1 b2 n -- : move character blocks around )
#0 max for aft >r c@+ r@ c! 1+ r> 1+ then next 2drop ;
: fill ( b n c -- : write byte 'c' to array 'b' of 'u' length )
swap #0 max for swap aft 2dup c! 1+ then next 2drop ;
: erase #0 fill ; ( b u -- : write zeros to array )
:s do$ 2r> 2* dup count + aligned 2/ >r swap >r ;s ( -- a )
:s ($) do$ ;s ( -- a : do string NB. )
:s .$ do$ count type ;s ( -- : print string in next cells )
:m ." .$ $literal ;m ( --, ccc" : compile string )
:m $" ($) $literal ;m ( --, ccc" : compile string )
: space bl emit ; ( -- : emit a space )
: catch ( xt -- exception# | 0 \ return addr on stack )
sp@ >r ( xt ) \ save data stack pointer
[ {handler} ] up @ >r ( xt ) \ and previous handler
rp@ [ {handler} ] up ! ( xt ) \ set current handler
execute ( ) \ execute returns if no throw
r> [ {handler} ] up ! ( ) \ restore previous handler
rdrop ( ) \ discard saved stack ptr
#0 ; ( 0 ) \ normal completion
: throw ( ??? exception# -- ??? exception# )
?dup if ( exc# ) \ 0 throw is no-op
[ {handler} ] up @ rp! ( exc# ) \ restore prev ret. stack
r> [ {handler} ] up ! ( exc# ) \ restore prev handler
r> swap >r ( saved-sp ) \ exc# on return stack
sp! r> ( exc# ) \ restore stack
then ;
: abort #-1 throw ; ( -- : Time to die. )
:s (abort) do$ swap if count type abort then drop ;s ( n -- )
:s depth [ {sp0} ] literal @ sp@ - 1- ;s ( -- n : stk. depth )
:s ?depth depth >= [ -$4 ] literal and throw ;s ( ??? n -- )
: um+ 2dup + >r r@ 0>= >r ( u u -- u carry )
2dup and 0< r> or >r or 0< r> and negate r> swap ;
: dnegate invert >r invert #1 um+ r> + ; ( d -- d )
: d+ >r swap >r um+ r> + r> + ; ( d d -- d )
: um* ( u u -- ud : double cell width multiply )
#0 swap ( u1 0 u2 )
[ $F ] literal for ( 16 times )
dup um+ 2>r dup um+ r> + r>
if >r over um+ r> + then
next shed ;
: * um* drop ; ( n n -- n : multiply two numbers )
: um/mod ( ud u -- ur uq : unsigned double cell div/mod )
?dup 0= [ -$A ] literal and throw ( divisor is non zero? )
2dup u<
if
negate
[ $F ] literal for ( 16 times )
>r dup um+ 2>r dup um+ r> + dup
r> r@ swap >r um+ r> ( or -> ) 0<> swap 0<> +
if >r drop 1+ r> else drop then r>
next
drop swap exit
then 2drop drop #-1 dup ;
: m/mod ( d n -- r q : floored division, hopefully not flawed )
s>d dup >r
if negate >r dnegate r> then
>r s>d if r@ + then r> um/mod r> ( modify um/mod result )
if swap negate swap then ;
: /mod over 0< swap m/mod ; ( u1 u2 -- u1%u2 u1/u2 )
: mod /mod drop ; ( u1 u2 -- u1%u2 )
: / /mod nip ; ( u1 u2 -- u1/u2 )
:s (emit) pause opEmit ;s ( c -- : output byte to terminal )
: echo <echo> @execute ; ( c -- : emit a single character )
:s tap dup echo over c! 1+ ;s ( bot eot cur c -- bot eot cur )
:s ktap ( bot eot cur c -- bot eot cur )
( Not EOL? )
dup dup [ =cr ] literal <> >r [ =lf ] literal <> r> and if
( Not Del Char? )
dup [ =bksp ] literal <> >r [ =del ] literal <> r> and if
bl tap ( replace any other character with bl )
exit
then
>r over r@ < dup if ( if not at start of line )
[ =bksp ] literal dup echo bl echo echo ( erase char )
then
r> + ( add 0/-1 to cur )
exit
then drop nip dup ;s ( set cur = eot )
: accept ( b u -- b u : read in a line of user input )
over + over begin
2dup <>
while
key dup
bl - [ $5F ] literal u< ( magic: within 32-127? )
if tap else <tap> @execute then
repeat drop over - ;
: expect <expect> @execute span ! drop ; ( a u -- )
: tib source drop ; ( -- b : get Terminal Input Buffer )
: query ( -- : get a new line of input, store it in TIB )
tib [ =buf ] literal <expect> @execute tup ! drop #0 >in ! ;
: -trailing for aft ( b u -- b u : remove trailing spaces )
bl over r@ + c@ < if r> 1+ exit then
then next #0 ;
:s look ( b u c xt -- b u : skip until *xt* test succeeds )
swap >r -rot
begin
dup
while
over c@ r@ - r@ bl = [ 4 ] literal pick execute
if rdrop shed exit then
+string
repeat rdrop shed ;s
:s unmatch if 0> exit then 0<> ;s ( c1 c2 -- t )
:s match unmatch invert ;s ( c1 c2 -- t )
: parse ( c -- b u ; <string> )
>r tib >in @ + tup @ >in @ - r@ ( get memory to parse )
>r over r> swap 2>r
r@ [ t' unmatch ] literal look 2dup ( find start of match )
r> [ t' match ] literal look swap ( find end of match )
r> - >r - r> 1+ ( b u c -- b u delta : compute match len )
>in +!
r> bl = if -trailing then
#0 max ;
:s banner ( +n c -- : output 'c' 'n' times )
>r begin dup 0> while r@ emit 1- repeat drop rdrop ;s
: hold #-1 hld +! hld @ c! ; ( c -- : save char in hold space )
: #> 2drop hld @ this [ =num ] literal + over - ; ( u -- b u )
:s extract ( ud ud -- ud u : extract digit from number )
dup >r um/mod r> swap >r um/mod r> rot ;s
:s digit ( u -- c : extract a character from number )
[ 9 ] literal over < [ 7 ] literal and + [char] 0 + ;s
: # #2 ?depth #0 radix extract digit hold ; ( d -- d )
: #s begin # 2dup ( d0= -> ) or 0= until ; ( d -- 0 )
: <# this [ =num ] literal + hld ! ; ( -- : start num. output )
: sign 0>= ?exit [char] - hold ; ( n -- )
: u.r >r #0 <# #s #> r> over - bl banner type ; ( u r -- )
: u. space #0 u.r ; ( u -- : unsigned numeric output )
opt.divmod [if]
:s (.) abs radix opDivMod ?dup if (.) then digit emit ;s
: . space s>d if [char] - emit then (.) ; ( n -- )
[else]
: . space dup >r abs #0 <# #s r> sign #> type ; ( n -- )
[then]
: >number ( ud b u -- ud b u : convert string to number )
dup 0= ?exit
begin
2dup 2>r drop c@ radix ( get next character )
( digit? -> ) >r [char] 0 - [ 9 ] literal over <
if
( next line: c base -- u f )
[ 7 ] literal - dup [ $A ] literal < or then dup r> u<
0= if ( d char )
drop ( d char -- d )
2r> ( restore string )
exit ( finished...exit )
then ( d char )
swap radix um* drop rot radix um* d+ ( accumulate digit )
2r> ( restore string )
+string dup 0= ( advance, test for end )
until ;
: number? ( a u -- d -1 | a u 0 : easier to use than >number )
#-1 dpl !
radix >r
over c@ [char] - = dup >r if +string then
over c@ [char] $ = if hex +string
( dup 0= if dup rdrop r> base ! exit then )
then
2>r #0 dup 2r>
begin
>number dup
while over c@ [char] . <>
if shed rot r> 2drop #0 r> base ! exit then
1- dpl ! 1+ dpl @
repeat
2drop r> if dnegate then r> base ! #-1 ;
: .s depth for aft r@ pick . then next ; ( -- : show stack )
: compare ( a1 u1 a2 u2 -- n : string comparison )
rot
over - ?dup if >r 2drop r> nip exit then
for ( a1 a2 )
aft
count rot count rot - ?dup
if rdrop nip nip exit then
then
next 2drop #0 ;
: nfa cell+ ; ( pwd -- nfa : move word ptr to name field )
: cfa ( pwd -- cfa : move to Code Field Address )
nfa c@+ [ 1F ] literal and + cell+ -cell and ;
:s (search) ( a wid -- PWD PWD 1 | PWD PWD -1 | 0 a 0 )
\ Search for word "a" in "wid"
swap >r dup
begin
dup
while
( $9F = $1F:word-length + $80:hidden )
dup nfa count [ $9F ] literal
and r@ count compare 0=
if ( found! )
rdrop
dup ( immediate? -> ) nfa [ $40 ] literal swap @ and 0<>
#1 or negate exit
then
nip @+
repeat
rdrop 2drop #0 ;s
:s (find) ( a -- pwd pwd 1 | pwd pwd -1 | 0 a 0 : find a word )
>r
context
begin
@+
while
@+ @ r@ swap (search) ?dup
if
>r shed r> rdrop exit
then
cell+
repeat drop #0 r> #0 ;s
: search-wordlist ( a wid -- PWD 1|PWD -1|a 0 )
(search) shed ;
: find ( a -- pwd 1 | pwd -1 | a 0 : find word in dictionary )
(find) shed ;
: compile r> dup [@] , 1+ >r ; compile-only ( -- )
:s (literal) state @ if compile (push) , then ;s ( u -- )
:to literal <literal> @execute ; immediate ( u -- )
: compile, ( align <- called by "," ) 2/ , ; ( xt -- )
:s ?found ?exit ( b f -- b | ??? )
space count type [char] ? emit cr [ -$D ] literal throw ;s
: interpret ( b -- : interpret a counted word )
find ?dup if
state @
if
0> if cfa execute exit then \ <- execute immediate words
cfa compile, exit \ <- compiling word are...compiled.
then
drop
( next line performs "?compile" )
dup nfa c@ [ 20 ] literal and 0<> [ -$E ] literal and throw
\ if it's not compiling, execute it then exit *interpreter*
cfa execute exit
then
\ not a word
dup >r count number? if rdrop \ it is numeric!
dpl @ 0< if \ <- dpl is -1 if it's a single cell number
drop \ drop high cell from 'number?' for single cell
else \ <- dpl is not -1, it is a double cell number
state @ if swap then
postpone literal \ literal executed twice if # is double
then \ NB. "literal" is state aware
postpone literal exit
then
\ N.B. Could vector ?found here, to handle arbitrary words
r> #0 ?found ;
: get-order ( -- widn...wid1 n : get current search order )
context
\ next line finds first empty cell
#0 >r begin @+ r@ xor while cell+ repeat rdrop
dup cell- swap
context - 2/ dup >r 1- s>d [ -$32 ] literal and throw
for aft @+ swap cell- then next @ r> ;
:r set-order ( widn ... wid1 n -- : set current search order )
\ NB. Uses recursion, however the meta-compiler does not use
\ the Forth compilation mechanism, so the current definition
\ of "set-order" is available immediately.
dup #-1 = if drop root-voc #1 set-order exit then
dup #vocs > [ -$31 ] literal and throw
context swap for aft tuck ! cell+ then next #0 swap ! ;r
: (order) ( w wid*n n -- wid*n w n )
dup if
1- swap >r ( recurse -> ) (order) over r@ xor
if 1+ r> -rot exit then rdrop
then ;
: -order ( wid -- : remove vocabulary from search order )
get-order (order) nip set-order ;
: +order ( wid -- : add vocabulary to search order )
dup >r -order get-order r> swap 1+ set-order ;
root[
{forth-wordlist} constant forth-wordlist ( -- wid )
{system} constant system ( -- wid )
]root
:r forth ( -- : set system to contain default vocabularies )