-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathuf.f
1982 lines (1652 loc) · 70.7 KB
/
uf.f
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
\ UF - Forth part
\
\ Once the kernel runs, it can be used to load and interpret this file, which
\ adds more words and saves various ROM files during the process, resulting
\ in Forth interpreters with varying functionality.
\
\ Stack comments have the same meaning as in "kernel.tal". Note that
\ the "(...)" Forth comment syntax is not yet available and will be added
\ below.
\
\ `literal` ( x -- ) Compile code to push a 16-bit value using LIT2k
: literal 160 c, , ;
\ Create next definitions in `compiler` vocabulary. During compilation
\ these immediate words generate inline UXN code instead of compiling to
\ procedure calls as is done for "normal" Forth words.
\ You can use it for your own optimizations: just define an immediate
\ word in the `compiler` vocabulary in addition to your normal non-immediate
\ word.
\
\ (idiom) `also` duplicates item on the vocabulary stack, `compiler` changes
\ topmost item to the `compiler` vocabulary, `definitions` makes the topmost
\ entry (now `compiler`) the one where future definitions are added.
also compiler definitions
\ `drop` ( x -- ) Pop topmost stack element, compiles a POP2
: drop 34 c, ; immediate
\ `nip` ( x y -- y ) Pop second stack element, compiles a NIP2
: nip 35 c, ; immediate
\ `swap` ( x y -- y x ) Swap stack elements, compiles SWP2
: swap 36 c, ; immediate
\ `rot` ( x y z -- y z x ) Rotate 3rd item to the top, compiles to ROT2
: rot 37 c, ; immediate
\ `-rot` ( x y z -- z x y ) Rotate top item to 3rd place, compiles to ROT2 ROT2
: -rot 37 c, 37 c, ; immediate
\ `dup` ( x -- x x) Duplicate top item, compiles to DUP2
: dup 38 c, ; immediate
\ `over` ( x y -- x y x ) Copies 2nd item to the top, compiles to OVR2
: over 39 c, ; immediate
\ `2dup` ( x y -- x y x y ) Duplicate 2 topmost items, compiles to OVR2 OVR2
: 2dup 39 c, 39 c, ; immediate
\ `2drop` ( x y -- ) Drops 2 topmost items, compiles to POP2 POP2
: 2drop 34 c, 34 c, ; immediate
\ `+` ( n1 n2 -- n3 ) Add 2 items, compiles to ADD2
: + 56 c, ; immediate
\ `-` ( n1 n2 -- n3 ) Subtract top item from the 2nd, compiles to SUB2
: - 57 c, ; immediate
\ `*` ( n1 n2 -- n3 ) Multiply, compiles to MUL2
: * 58 c, ; immediate
\ `u/` ( u1 u2 -- u3 ) Unsigned division, compiles to DIV2
: u/ 59 c, ; immediate
\ `and` ( x1 x2 -- x3 ) Bitwise AND, compiles to AND2
: and 60 c, ; immediate
\ `or` ( x1 x2 -- x3 ) Bitwise OR, compiles to ORA2
: or 61 c, ; immediate
\ `xor` ( x1 x2 -- x3 ) Bitwise XOR, compiles to EOR2
: xor 62 c, ; immediate
\ `=` ( x1 x2 -- f ) Pushes 1 if x1 is equal to x2 or 0 otherwise, compiles to EQU2 DUP
: = 40 c, 6 c, ; immediate
\ `<>` ( x1 x2 -- f ) Pushes 1 if x1 is not equal to x2 or 0 otherwise, compiles
\ to NEQ2 DUP
: <> 41 c, 6 c, ; immediate
\ `u>` ( u1 u2 -- f ) Pushes 1 if u1 is higher than u2 or 0 otherwise, compiles
\ to GTH2 DUP
: u> 42 c, 6 c, ; immediate
\ `u<` ( u1 u2 -- f ) Pushes 1 if u1 is below u2 or 0 otherwise, compiles to LTH2 DUP
: u< 43 c, 6 c, ; immediate
\ `0<` ( n -- f ) Pushes $8000 if n is negative or 0 otherwise, compiles to #15 SFT2
: 0< 128 c, 15 c, 63 c, ; immediate
\ `>r` ( x -- ) Pop a value from the data stack and pushes it onto the return stack,
\ compiles to STH2
: >r 47 c, ; immediate
\ `dup>r` ( x -- x ) Push the top item from the data stack and pushes it onto the
\ return stack, compiles to STH2k
: dup>r 175 c, ; immediate
\ `r>` ( -- x ) Pops the top item from the return stack and pushes it onto the data
\ stack, compiles to STH2r
: r> 111 c, ; immediate
\ `r>drop` ( -- ) Drops the top item from the return stack, compiles to POP2r
: r>drop 98 c, ; immediate
\ `r@` ( -- x ) Pushes the top item from the return stack onto the data stack,
\ compiles to STH2kr
: r@ 239 c, ; immediate
\ `1+` ( n1 -- n2 ) Adds 1 to the topmost stack item, compiles to INC2
: 1+ 33 c, ; immediate
\ `1-` ( n1 -- n2 ) Subtracts 1 to the topmost stack item, compiles to #0001 SUB2
: 1- 160 c, 1 , 57 c, ; immediate
\ `cell+` ( n1 -- n2 ) Adds 2 to the topmost stack item, compiles to INC2 INC2
: cell+ 33 c, 33 c, ; immediate
\ `exit` ( -- ) Returns from the current word, compiles to JMP2r
: exit 108 c, ; immediate
\ `@` ( a -- x ) Fetches the short from the given address and pushes it on the data stack,
\ compiles to LDA2
: @ 52 c, ; immediate
\ `!` ( x a -- ) Stores the 2nd item from the stack at the address at the top of the
\ stack, compiles to STA2
: ! 53 c, ; immediate
\ `c@` ( a -- c ) Fetches a byte, compiles to LDA #00 SWP
: c@ 20 c, 128 c, 0 c, 4 c, ; immediate
\ `c!` ( c a -- ) Stores a byte, compiles to STA POP
: c! 21 c, 2 c, ; immediate
\ `2*` ( n1 -- n2 ) Multiples by 2, compiles to #10 SFT2
: 2* 128 c, 16 c, 63 c, ; immediate
\ `2/` ( n1 -- n2 ) Divides by 2, compiles to #1 SFT2
: 2/ 128 c, 1 c, 63 c, ; immediate
\ `cells` ( n1 -- n2 ) Multiples by size of short (i.e. 2), same as `2*`
: cells 128 c, 16 c, 63 c, ; immediate
\ `2>r` ( x y -- ) Takes 2 values from the data stack and pushes them on the return
\ stack, compiles to SWP2 STH2 STH2
: 2>r 36 c, 47 c, 47 c, ; immediate
\ `2r>` ( -- x y ) Takes 2 values from the return stack and pushes them on the data
\ stack, compiles to STH2r STH2r SWP2
: 2r> 111 c, 111 c, 36 c, ; immediate
\ `execute` ( xt -- ) Calls a word (any UXN code, in fact), compiles to JSR2
: execute 46 c, ; immediate
\ `brk` ( -- ) Stops UXN VM, waiting for events, compiles to BRK
: brk 0 c, ; immediate
\ `[_']` ( | <word> -- xt ) Compiles the address of the next word in the input stream
\ as a literal value, compiles to LIT2k
: [_'] ' literal ; immediate
\ `[']` ( | <word> -- xt ) Similar to `[_']`, but ignores the topmost entry in the
\ vocabulary stack; this is done to make `[']` to skip the `compiler` vocabulary -
\ when we want to fetch word addresses during compile time, we want the real Forth
\ word addresses, not the immediate code generators that compile code inline.
: ['] vocs @ >r null vocs ! ' literal r> vocs ! ; immediate
\ We are done with `compiler` words, now switch back to the `forth` vocabulary
only definitions
\ `on` ( a -- ) Store -1 at the given address
: on -1 swap ! ;
\ `off` ( a -- ) Store 0 at the given address
: off 0 swap ! ;
\ The following are just "proper" variants of the inline words defined earlier in
\ the `compiler` vocabulary, these are invoked in interpreted mode or when referred
\ to via `[']`/`'`.
: + + ;
: - - ;
: * * ;
: u/ u/ ;
: u< u< ;
: u> u> ;
: r> r> ;
: >r >r ;
: dup>r dup>r ;
: r>drop r>drop ;
: r@ r@ ;
: c! c! ;
: c@ c@ ;
: ! ! ;
: @ @ ;
: and and ;
: or or ;
: xor xor ;
: = = ;
: <> <> ;
: drop drop ;
: nip nip ;
: dup dup ;
: swap swap ;
: rot rot ;
: over over ;
: 1+ 1+ ;
: 1- 1- ;
: 2* 2* ;
: 2/ 2/ ;
: 0< 0< ;
: 2r> 2r> ;
: 2>r 2>r ;
: -rot -rot ;
: 2drop 2drop ;
: 2dup 2dup ;
: brk brk ;
: cells cells ;
: cell+ cell+ ;
\ `0=` ( x -- f ) Compares with zero
: 0= 0 = ;
\ `>=` ( n1 n2 - f ) Push 1 if first argument is greater or equal to second or 0 otherwise
: >= 1- swap < ;
\ `<=` ( n1 n2 - f ) Push 1 if first argument is less or equal to second or 0 otherwise
: <= 1+ swap > ;
\ `2r@` ( -- x y ) Pushes 2 topmost items from the return stack on the data stack
: 2r@ r> 2r> over over 2>r >r ;
\ `here` ( -- a ) Push address of first unused byte
: here h @ ;
\ `forth` ( -- ) Set topmost entry in vocabulary stack to default `forth` vocabulary
: forth dp vocs ! ;
\ `]` ( | ... -- ) push `compiler` vocabulary on vocabulary stack and start compiling
\ further words in input stream
: ] also compiler (compile) ;
\ `invert` ( x1 -- x2 ) Invert bits of topmost stack item
: invert -1 xor ;
\ `negate` ( n1 -- n2 ) Negate topmost stack item
: negate 0 swap - ;
\ `2nip` ( x y v w -- v w ) Drop 4d and 4th stack item
: 2nip rot drop rot drop ;
\ `2swap` ( x y v w -- v w x y ) Swap topmost item pairs on stack
: 2swap rot >r rot r> ;
\ `2over` ( x y v w -- x y v w x y ) Copy 2nd item pair to top
: 2over >r >r 2dup r> -rot r> -rot ;
\ `2rot` ( x y v w p q -- v w p q x y ) Rotate item pairs
: 2rot >r >r 2swap r> r> 2swap ;
\ `(` ( | ...) ) Skip characters in input stream until next ")"
: ( 41 parse 2drop ; immediate
\ `char` ( | <word> -- c ) Parse next word in input stream and push the ASCII code
\ of its first character
: char 32 word 1+ c@ ;
\ `sliteral` ( -- a u ) compile a string literal into the code area, the string
\ will be embedded and skipped over, leaving address and length on the stack
: sliteral ['] (slit) compile, tuck here place 1+ allot ;
\ `unloop` ( -- ) pop 2 items from the return stack, making sure to keep the return
\ address, used to exit prematurely out of DO ... LOOP constructs
: unloop r> r>drop r>drop >r ;
\ `execute` ( xt -- ) `execute`, but making sure to keep the return address
: execute r>drop execute ;
\ `cr` ( -- ) Write a newline using `emit`
: cr 10 emit ;
\ Further words for the `compiler` vocabulary, mostly control structures, compiler
\ state manipulation and compiling inline literal
also compiler definitions
\ `[char]` ( | <word> -- c ) Generate code to push the first character of the
\ next word in the input stream at run time
: [char] char literal ; immediate
\ `s"` ( | ..." -- a u ) Compile a string constant, pushing address and length
: s" ( | ..." -- a u ) [char] " parse sliteral ; immediate
\ `."` ( | ..." -- ) Compile a string literal and write it out using `type`
: ." ( | ..." -- )
[char] " parse sliteral ['] type compile, ; immediate
\ `[` ( -- ) Switch to interpreted state and change topmost vocabulary stack entry
\ to the `forth` vocabulary
: [ state off forth ; immediate
\ `if` ( f | ... -- ) Conditional branch, compiles a call to `(if)` followed by the
\ address to branch to, initially 0, later patched by `else` or `then`. The patch
\ address will be kept on the data stack at compile time
: if ['] (if) compile, here 0 , ; immediate
\ `else` ( | ... -- ) Compile an unconditional branch and patch up the pending
\ jump from the previous `if`, keep new patch address on stack
: else ['] (else) compile, here 0 , swap here swap ! ; immediate
\ `then` ( -- ) Patch previous jump, completing the `if` sequence
: then here swap ! ; immediate
\ `cjump,` ( a -- ) Compile a conditional backward jump (JCN[2]), used for loops
: cjump, jumpaddr, if 45 else 13 then c, ;
\ `jump,` ( a -- ) Compile an unconditional jump (JMP[2])
: jump, jumpaddr, if 44 else 12 then c, ;
\ `begin` ( -- ) Start loop, just holding address on data stack during compile time
: begin here ; immediate
\ `again` ( -- ) Compile jump to address on data stack at compile time
: again jump, ; immediate
\ `until` ( f -- ) Compile a conditional (absolute) jump to address pushed on data
\ stack by previous `begin` at compile time
: until ['] (if) compile, , ; immediate
\ `while` ( f -- ) Comple a conditional forward jump and leave patch address on data
\ stack for BEGIN ... WHILE ... REPEAT loop
: while ['] (if) compile, here 0 , ; immediate
\ `repeat` ( -- ) Patch up branch and compile backwards jump
: repeat swap jump, here swap ! ; immediate
\ `(?abort`) ( f a u -- ) If flag is true, show string using `type` and abort,
\ used for `abort"`
: (?abort) rot if type cr abort else 2drop then ;
\ `abort"` ( f | ..." -- ) Show message and abort if flag is true
: abort" [char] " parse sliteral ['] (?abort) compile, ; immediate
\ `|` ( -- ) Compile `exit` and patch existing jump address on data stack
: | [_'] exit execute here swap ! ; immediate
\ `->` ( x y | ... -- x ) Compare topmost stack entry with 2nd and skip code until
\ next `|` (or `then`) if they don't match, otherwise drop topmost item and
\ continue
: -> [_'] over execute [_'] = execute ['] (if) compile, here 0 ,
[_'] drop execute ; immediate
\ `postpone` ( | <word> -- ) Look up the next word in the input stream and compile
\ it - it is immediate, compile a call, if not then compile code that compiles a
\ call
: postpone also forth
32 word find previous 0 -> undefd |
1 -> compile, | drop literal ['] compile, compile, ;
immediate
\ `(does>)` ( -- ) Change the code field of the most recently created word to
\ Jump to the code following this word; this requires that the code field
\ starts with a JSI sequence
: (does>) r> current @ @ count 63 and + 2 + 1+ tuck - 2 - swap ! ;
\ `does>` ( | ... -- a ) Compiles a call to `(does>)` followed by STH2r, effectively
\ changing the previously defined word to execute the following code, with the
\ parameter field address pushed on the stack (of the data following the branch to
\ the current location)
: does> ['] (does>) compile, 111 c, ; immediate
\ `do` ( u1 u2 | ... loop -- ) Start a DO ... LOOP construct, pushing the start and
\ limit on the return stack, compiling SWP2 STH2 STH2; leaves a 0 and the current code
\ address on the data stack at compile time
: do 36 c, 47 c, 47 c, 0 here ; immediate
\ `?do` ( u1 u2 | ... loop -- ) Variant of `do` that checks limits before first
\ iteration, compiling SWP2 STH2 STH2 #0000 #0000 JMP2; the latter jump address
\ will be patched up to jump to the end of the loop before entering it the
\ first time
: ?do 36 c, 47 c, 47 c, 0 literal 0 literal here 2 - 44 c, here ; immediate
\ `patchloop` ( f a -- a ) Patches up a forward jump if the flag is true
: patchloop swap ?dup if here swap ! then ;
\ `+loop` ( u -- ) Patches up forward branch and compiles `(loop)` which increases
\ the loop index by u and branches back to the start of the loop if the limit is not
\ reached yet
: +loop patchloop ['] (loop) compile, cjump, ; immediate
\ `loop` ( -- ) Like `+loop`, increasing the loop index by 1
: loop 1 literal patchloop ['] (loop) compile, cjump, ; immediate
\ `-;` ( -- ) Changes last compiled instruction from call to jump,
\ changing JSI to JMI; if the previous instruction is not a call then
\ compile a JMP2r (normal return)
: tailjump here 3 - dup c@ 96 = if 64 swap c! | drop 108 c, ;
: -; current @ @ here <> if tailjump else 108 c, then
state off reveal ; immediate
\ back to `forth` vocabulary
only definitions
\ `constant` ( x | <word> -- ) Define a constant word in the dictionary
: constant head ['] (constant) compile, , ;
\ `variable` ( | <word> -- ) Define a variable
: variable head ['] (variable) compile, 0 , ;
\ `create` ( | <word> -- ) Create a header without any code (yet)
: create head ['] (variable) compile, ;
\ `buffer:` ( u | <word> -- ) Create a variable header for a buffer of u bytes
: buffer: create allot ;
\ `false` ( -- 0 ) The global "false" value
0 constant false
\ `true` ( -- -1 ) The canonical "true" value
-1 constant true
\ `bl` ( -- 32 ) The space character constant
32 constant bl
\ `"` ( | ..." -- a u ) Define a string constant at interpretation time, this
\ is not for compiled code, use `s"` there!
: " [char] " parse >r here r@ cmove here r> dup allot ;
\ `under+` ( n1 x n2 -- n3 x ) Add top item on data stack to the 3rd item
: under+ rot + swap ;
\ `th` ( a1 u -- a2 ) Compute address of u-th short at address a1
: th 2* + ;
\ `min` ( n1 n2 -- n1/2 ) Minimum value
: min 2dup < if drop else nip then ;
\ `max` ( n1 n2 -- n1/2 ) Maximum value
: max 2dup > if drop else nip then ;
\ `pad` ( -- a ) Temporary address as scratch memory, valid until the next `allot`,
\ `,`, `c,`
: pad here 256 + ;
\ internal buffer for filenames
256 buffer: fnbuf
\ `filename` ( a u -- ) Set filename slot in file device to the string given,
\ terminated by a zero character
: filename 255 min fnbuf place 0 fnbuf dup c@ + 1+ c!
fnbuf 1+ 168 deo2 ;
\ `filewrite` ( a u -- u2 ) Write buffer to file, return number of bytes written
: filewrite ( a u -- u2 ) 0 167 deo 170 deo2 174 deo2 162 dei2 ;
\ `fileappend` ( a u -- u2 ) Append buffer to file, return number of bytes written
: fileappend ( a u -- u2 ) 1 167 deo 170 deo2 174 deo2 162 dei2 ;
\ `fileread` ( a u -- u2 ) Read bytes from file, return number of bytes read
: fileread ( a u -- u2 ) 170 deo2 172 deo2 162 dei2 ;
\ `filedelete` ( -- ) Delete file designated by filename device slot
: filedelete 1 166 deo ;
\ `saved` ( a1 u1 a2 u2 -- ) Write buffer at a1/u1 to file named by a2/u2 and
\ report error when writing was unsuccessful (0 bytes were written)
: saved filename filewrite 0= abort" saving file failed" ;
\ `save` ( | <word> -- ) Write area from 0100 to top of used memory to file named
\ by the next word in the input stream
: save 256 here 256 - bl word count saved ;
\ `loadrom` ( a u -- ) Load ROM file named by a/u and start executing it
: loadrom ( a u -- ) filename (loadrom) ;
\ `crash` ( ... -- ) Show error indicating an uninitialized deferred word
: crash ." uninitialized execution vector" cr abort ;
\ `defer` ( | <word> -- ) Define a "deferred" word, which can be changed later,
\ the initial behaviour is to call `crash` via a ";crash JSR2" sequence,
\ that way we can easily change the (absolute) target address
: defer head ['] crash literal 44 c, ;
\ `defer!` ( xt1 xt2 -- ) Change the deferred word xt2 to call xt1
\ we add a check for LIT2, otherwise accessing non-deferred words this way
\ will be very hard to debug
: ?defer ( xt -- a ) count 160 <> abort" not a deferred word" ;
: defer! ?defer ! ;
\ `defer@` ( xt1 -- xt2 ) Fetch the execution token that is called when the
\ deferred word xt1 is invoked
: defer@ ?defer @ ;
\ `is` ( xt | <word> -- ) Change the deferred word given in the input stream to
\ call xt when invoked
: is ' defer! ;
\ `bye` ( -- ) Deferred word to terminate UXN
defer bye
: (bye) 1 15 deo brk ;
' (bye) is bye
\ A "vocabulary" is a separate chain of definition headers that can be added
\ to the vocabulary stack to make definitions visible (via `find`).
\ The vocabularies are chained together to be able to list them and restore
\ them in bulk to a previous state. The structure is as follows
\
\ +--------+--------+--------+
\ | <link> | <name> | <next> |
\ +--------+--------+--------+
\
\ The <link> points to the header of the first defined word in the vocabulary or
\ is zero to indicate the end of the chain. <Name> points to the counted string
\ of the name of the vocabulary and <next> points to the next vocabulary (or 0)
\ `find` searches vocabularies in the order in which they are pushed on the
\ vocabulary stack, the latest (topmost) is searched first.
\ `>voc` ( -- a ) A chain connecting all defined vocabularies
variable >voc ' cdp 3 + >voc !
\ `vocabulary` ( | <word> -- ) Creates a new vocabulary, when <word> is invoked,
\ the current vocabulary will be set to this
: vocabulary create >voc @ here >voc ! 0 , current @ @ , , does> vocs ! ;
\ `hex` ( -- ) Switch numeric base for conversion to 16
: hex 16 base ! ;
\ `decimal` ( -- ) Switch numeric base for conversion to 10
: decimal 10 base ! ;
\ `+!` ( n a -- ) Increase value at address by n
: +! dup>r @ + r> ! ;
\ `@+` ( a1 -- a2 x ) Fetch short from a1 and increase address by 2
: @+ dup @ >r 2 + r> ;
\ `!+` ( a1 x -- a2 ) Store short x at a1, increase the address by 2
: !+ over ! 2 + ;
\ `space` ( -- ) Write a space character using `emit`
: space bl emit ;
\ `emits` ( c u -- ) Emit c u times
: emits begin ?dup while over emit 1- repeat drop ;
\ `spaces` ( u -- ) Emit u spaces
: spaces bl swap emits ;
\ `erase` ( a u -- ) Fill an area of memory with zero bytes
: erase 0 fill ;
\ `blank` ( a u -- ) Fill an area of memory with space characters
: blank bl fill ;
\ `0<>` ( n -- f ) Compare value with 0, push -1 if non-null or 0 otherwise
: 0<> if -1 else 0 then ;
\ `bounds` ( a1 n -- a2 a1 ) Take address and length and convert to end and start
\ addresses (the latter is directly above the last byte)
: bounds over + swap ;
\ `?exit` ( f -- ) Exit colon word when f is true
: ?exit if r>drop then ;
\ `.(` ( | ... ) ) Read string from the input stream terminated by ")" and print
\ it, this is a variant of `."` for use outside of colon definitions
: .( [char] ) parse type ;
\ `-trailing` ( a u1 -- a u2 ) Shorten a string (address + length) by deducing the
\ trailing space characters from the length
: -trailing begin 1- dup 0< if 1+ | 2dup + c@ bl <> until 1+ ;
\ `clamp` (n min max -- n2 ) Ensure n is between min and max
: clamp rot min max ;
\ `2@` ( a - x y ) Read 2 shorts at address, the higher short first
: 2@ dup cell+ @ swap @ ;
\ `2!` ( x y a -- ) Write 2 shorts to address, the topmost item is placed first
: 2! swap over ! cell+ ! ;
\ `:noname` ( | ... -- xt ) Compile the rest of the input stream and push an execution
\ token that can be used to invoke it
: :noname also compiler here (compile) ;
\ `aligned` ( u1 -- u2 ) align to 2 boundary
: aligned dup 1 and if 1+ then ;
\ `align` ( -- ) Align the current free memory pointer (`h`)
: align here aligned h ! ;
\ `diff` ( n1 n2 -- n3 ) "Reverse" subtraction
: diff swap - ;
\ `2variable` ( | <word> -- ) Define a variable pointing to a double word
: 2variable create 0 , 0 , ;
\ `2constant` ( x y | <word> -- ) Define a constant that pushes a double word when
\ called
: 2constant head ['] (2constant) compile, swap , , ;
\ Numeric formatting: a simple way of formatting numeric data, intermixed
\ with text. After starting the formatting with `<#`, consecutive characters and digits
\ are stored in the `pad` from back to front until `#>` is executed, which leaves
\ the address and length of the formatted string on the stack.
\ `>num` ( -- a ) Variable holding the pointer to the end of the formatted string
variable >num
\ `<#` ( -- ) Start formatting
: <# pad >num ! ;
\ `#` ( u1 -- u2 ) Take the last digit of u1 (in the numeric base designed by `base`)
\ and store it in the "hold" area
: # base @ u/mod swap dup 9 u> if
[char] a + 10 - else [char] 0 + then >num @ 1- dup >num ! c! ;
\ `#s` ( u -- 0 ) Store consecutive digits in the "hold" area using `#` until n is 0
: #s begin # dup while repeat ;
\ `#>` ( x -- a n ) Drop x and push the contents of the "hold" area
: #> drop >num @ dup pad swap - ;
\ `hold` ( c -- ) Add single character to "hold" area, at the front
: hold >num @ 1- dup>r c! r> >num ! ;
\ `holds` ( a u -- ) Move the string given by a/u to the front in the "hold" area
: holds dup>r negate >num +! >num @ r> cmove ;
\ `sign` ( n -- ) "Holds" a "-" character if n is negative
: sign ( n -- ) 0< if [char] - hold then ;
\ `(u.)` ( u1 -- a u2 ) Converts the unsigned number u1 to a string in the `pad`
\ and pushes its address and length
: (u.) <# #s #> ;
\ `u.` ( u -- ) Converts u to a string and prints it using `type`
: u. (u.) type space ;
\ `(.)` ( n -- a u ) Converts the signed number n to a string in the `pad` and
\ pushes its address and length
: (.) dup abs <# #s swap sign #> ;
\ `.` ( n -- ) Converts n to a string and prints it using `type`
: . (.) type space ;
\ `h.` ( u -- ) Prints u in hexadecimal base using `type`
: h. base @ >r hex u. r> base ! ;
\ `u.r` ( u1 u2 -- ) Converts u1 to a string and prints it using `type`, padded
\ on the left with spaces up to a total length of u2
: u.r >r <# #s #> r> over - 0 max spaces type ;
\ `.r` ( n u -- ) Converts n to a string and prints it using `type`, padded
\ on the left with spaces up to a total length of u
: .r >r dup abs <# #s swap sign #> r> over - 0 max spaces type ;
\ `.s` ( ... -- ... ) Prints all elements in the data stack in reverse order using `.`
: .s depth ?dup 0= if ." stack empty " |
dup 0 do dup i - pick . loop drop ;
\ `search` ( a1 u1 a2 u2 -- a3 u3 f ) Search the string a2/u2 in the string a1/u1
\ and push the address and length of location where it was found and a flag
\ indicating success or failure
variable /search
: search
/search ! swap dup>r /search @ - 1+ 0 do
over i + over /search @ swap /search @ compare 0= if
drop i + i unloop r> swap - true | loop drop r> false ;
\ `scan` ( a1 u1 c -- a2 u2 ) Search for byte c in the string a1/u1 and push
\ the address and remaining length of the location where it was found
: scan
>r begin dup while over c@ r@ = if r>drop |
1 /string repeat r>drop ;
\ Some more compiler words
also compiler definitions
\ `is` ( xt | <word> -- ) See `is` above, this compiles inline code
: is ' literal ['] defer! compile, ; immediate
\ `recurse` ( -- ) compile a recursive call to the currently defined colon definition
\ (as the current definition is "smudged" and not visible during compilation)
: recurse current @ @ count + 2 + compile, ; immediate
\ Save the basic UF ROM file "uf0.rom", containing only the absolute minimum
\ for a working, non-graphical Forth system
only definitions
\ enable prompt when ROM is loaded
' (prompt) is prompt
.( saving uf0.rom ... ) cr
save uf0.rom
\ disable prompt again during further loading of this file
' noop is prompt
\ Some handy things
\ `?` ( a -- ) Print contents of address a using `.`
: ? @ . ;
\ `based` ( u1 u2 | <word> -- n ) Convert next word in input stream to a number using
\ the base u2 and push it on the stack, reset `base` afterwards to u1
: based base ! bl word number r> r> base ! >r ?exit
count type ." bad number" cr abort ;
\ `h#` ( | <word> -- n ) Convert next word in input stream as hex number and push
\ it on the stack
: h# base @ >r 16 based ;
\ `d#` ( | <word> -- n ) Convert next word in input stream as decimal number and push
\ it on the stack
: d# base @ >r 10 based ;
\ `h#` and `d#` for compile time use inside colon definitions
also compiler definitions
: h# h# literal ; immediate
: d# d# literal ; immediate
only definitions
\ `heaptop` ( -- a ) Holds topmost address of usable heap, minus block buffers
h# ec40 constant heaptop
: unused heaptop here - ;
\ Loading of source code
\ `include` ( | <filename> -- )
\ `included` ( a u -- )
\ Both of these words redirect the input stream to the contents of the file with
\ the name given either as address/length pair or directly following the `include` form.
\ As available memory is constrained, the length of the source code may not exceed
\ half of the remaining space between `h` and `heaptop`. If you want to load longer
\ files (like this one), you can simple pass it as standard input when invoking
\ "uxncli" or "uxnemu":
\
\ uxncli ufc.rom < FILENAME
\
variable >include variable incend
variable oldquery variable oldabort
: endinclude oldquery @ ['] query defer! ['] (prompt) is prompt
oldabort @ ['] abort defer! >limit @ >in ! >include off ;
: abortinc endinclude abort ;
: eol ( a1 -- a2 f )
count 13 -> dup 1- bl swap c! false |
10 -> true | drop false ;
: inc-line >include @ dup incend @ >= if drop endinclude |
begin
dup incend @ >= if drop endinclude |
eol if 1- >include @ - >r >include @ tib r@ cmove
tib >in ! tib r@ + >limit ! r> 1+ >include +! |
again ;
: included ( a u -- )
>include @ abort" nested `include` is not supported"
filename heaptop here - 2/ heaptop over - dup >include !
swap fileread 0 -> true abort" no such file" |
>include @ + dup incend ! heaptop = abort" file too big"
['] query defer@ oldquery !
['] inc-line is query ['] noop is prompt ['] abort defer@
oldabort ! ['] abortinc is abort ;
: include ( | <name> -- ) bl word count included ;
\ "Varvara" device interface
\ System device:
\ `evector` ( xt -- ) Set "catch" vector, used by UF to catch machine errors
\ Note that the vector can be an arbitrary Forth execution token
: evector 0 deo2 ;
\ Default handler for the "catch" vector, set during boot time
: catcher ( inst/code -- )
255 and
1 -> ." stack underflow" cr abort |
2 -> ." stack overflow" cr abort |
3 -> ." division by zero" cr abort |
." unknown machine error" cr abort ;
\ `colors` ( r g b -- ) Set red/green/blue shorts
: colors 12 deo2 10 deo2 8 deo2 ;
\ `halt` ( status -- ) Exit UXN VM with status code
: halt h# 80 or 15 deo brk ;
\ Console device:
\ `cvector` ( xt -- ) Set console vector, used in the editor to handle
\ additional console input
: cvector 16 deo2 ;
\ `input-type` ( -- u ) Return input "type" byte from console
: input-type ( -- u ) h# 17 dei ;
\ Screen device:
\ `svector` ( xt -- ) Set screen vector
: svector 32 deo2 ;
\ `screensize@` ( -- u1 u2 ) Retrieve the screen size in pixels with the width
\ in u1 and the height in u2
: screensize@ 34 dei2 36 dei2 ;
\ `screensize!` ( u1 u2 -- ) Sets the screensize to width u1 and height u2
: screensize! swap 34 deo2 36 deo2 ;
\ `position` ( u1 u2 -- ) Sets the x and y position slots in the screen device
\ to u1 and u2, respectively
: position 42 deo2 40 deo2 ;
\ `pixel` ( u -- ) Sets the pixel mode
: pixel 46 deo ;
\ `auto` ( u -- ) Sets the "auto" byte
: auto 38 deo ;
\ `spritedata` ( a -- ) Sets the Screen/addr slot
: spritedata 44 deo2 ;
\ `sprite` ( u -- ) Sets the Screen/sprite slot
: sprite 47 deo ;
\ Audio device:
\ `devaudio` ( -- a ) Variable holding the currently selected audio device
variable devaudio h# 30 devaudio !
\ `audio` ( u -- ) Sets the current audio device, all further device access
\ operates on the selected one
: audio 4 lshift h# 30 + devaudio ! ;
\ `sample` ( a u -- ) Sets the sample address
: sample devaudio @ 10 + dup>r deo2 r> 2 + deo2 ;
\ `play` ( u -- ) Sets the Audio/pitch slot
: play devaudio @ 15 + deo ;
\ `adsr` ( u -- ) Sets the Audio/adsr slot
: adsr devaudio @ 8 + deo2 ;
\ `volume` ( u -- ) Sets the Audio/volume slot
: volume devaudio @ 14 + deo ;
\ `output` ( -- u ) Reads the current Audio/output slot
: output devaudio @ 4 + dei ;
\ Controller device:
\ `jvector` ( xt -- ) Sets the controller vector
: jvector 128 deo2 ;
\ `jbutton` ( -- u ) Reads out the Controller/button slot
: jbutton 130 dei ;
\ `jkey` ( -- u ) Reads out the Controller/key slot
: jkey 131 dei ;
\ Mouse device
\ `mvector` ( xt -- ) Sets the mouse vector
: mvector 144 deo2 ;
\ `mouse` ( -- u1 u2 ) Reads out the mouse x and y position as u1 and u2, respectively
: mouse 146 dei2 148 dei2 ;
\ `mscroll` ( -- u1 u2 ) Reads out the mouse x and y scroll values as u1 and u2,
\ respectively
: mscroll 154 dei2 156 dei2 ;
\ `mstate` ( -- u ) Reads out the Mouse/state slot
: mstate 150 dei ;
\ Daytime device
\ `year`, `month`, `day`, `hour`, `minute`, `second`, `dotw`, `doty` and `isdst`
\ return the associated numeric value from the daytime device
: year 192 dei2 ; : month 194 dei ; : day 195 dei ;
: hour 196 dei ; : minute 197 dei ; : second 198 dei ;
: dotw 199 dei ; : doty 200 dei2 ; : isdst 202 dei ;
\ `wait` ( -- ) Set Screen/vector and wait for events from other devices,
\ during this time the word `tick` is called 60 times per second (or less),
\ which should keep the stacks as they are on return
defer tick ' noop is tick
: waiting tick brk ;
: wait r>drop ['] waiting svector brk ;
\ Support for theme and snarf conventions:
\ `apply-theme` ( a -- ) Sets the System colors with the values found at the
\ 3 consecutive shorts at address a
: apply-theme @+ swap @+ swap @+ nip colors ;
\ `theme` ( -- ) Read the file ".theme" in the current directory into `pad`
\ and apply the colors found there using `apply-theme`
: theme s" .theme" filename pad 6 fileread if pad apply-theme then ;
\ `/snarfed` ( -- a ) Variable holding number of previously snarfed bytes
variable /snarfed
\ `snarf` ( a u -- ) Write the u bytes at the address a to the file ".snarf"
\ in the current directory, set `/snarfed`
: snarf dup /snarfed ! s" .snarf" filename filewrite drop ;
\ `yank` ( -- a u ) Load the data from the file ".snarf" in the current
\ directory to `pad` (if the file exists) and returns address and length
: yank s" .snarf" filename pad unused 4000 min fileread pad swap ;
\ Hex dumps
\
\ `dump` ( a u -- ) Writes a hex dump using `emit`, `.` and `type` from the
\ data at the given address and with the given length
: dumpascii ( a u -- ) space
0 do count dup 33 128 within 0= if drop [char] . then
emit loop drop ;
: dumpbyte ( c -- ) dup 16 < if [char] 0 emit then
base @ >r hex u. r> base ! ;
: dumprow ( a u -- a )
over u. space 0 do dup i + c@ dumpbyte loop ;
: dumprest ( a u -- ) dup>r dumprow 8 r@ - 3 * spaces
dup r> dumpascii ;
: dump ( a u -- ) 8 u/mod swap >r 0 ?do
8 dumprow dup 8 dumpascii cr 8 + loop
r> ?dup if dumprest then drop cr ;
\ Tools to inspect the dictionary
\ `order` ( -- ) Write the items on the vocabulary stack, the vocabulary
\ where definitions are created is shown in parantheses
: order 4 0 do
vocs i th @ cell+ @ ?dup if count type space then loop
current @ cell+ @ ?dup if [char] ( emit count type ." ) " then ;
\ `.vocs` ( -- ) Write out all existing vocabularies
: .vocs >voc @ begin ?dup while cell+ @+ count type space @
repeat ;
\ `significant` ( u1 -- u2 ) Rounds down the length in u1 to the number
\ of significant characters in a dictionary entry
: significant ( u1 -- u2 ) h# 3f and ;
\ `words` ( -- ) Show all visible words in the order found in all vocabularies
\ on the vocabulary stack
: words 4 0 do vocs i th @ @
begin ?dup while
count significant 2dup type space + @ repeat
loop ;
\ `marker` ( | <word> -- ) Creates a "marker", invoking this word restores
\ all vocabularies and the vocabulary stack to the state that existed when
\ the marker was created
: marker-save
>voc @ , current @ ,
vocs here 4 cells cmove 4 cells allot
>voc @ begin ?dup while
@+ , cell+ @ repeat here cell+ , ;
: marker-restore ( a -- )
@+ >voc ! @+ current !
dup vocs 4 cells cmove 4 cells +
>voc @ begin ?dup while
over @ over ! 2 under+ 2 cells + @ repeat
@ h ! ;
: marker ( | <word> -- )
create marker-save does> marker-restore ;
\ Interpreter conditionals
\
\ These words provide conditional execution/compilation and work both
\ in interpreted and compiled code.
: processword ( n1 a n2 -- n3 )
2dup s" [if]" compare 0= if 2drop 1+ |
2dup s" [else]" compare 0= if 2drop dup 1 = if 1- then |
s" [then]" compare 0= if 1- then ;
: skipwords ( | ... -- )
1 begin bl word dup c@ 0= if drop query
else count processword then
?dup 0= until ;
\ `[if]` ( f | ... -- ) Skip characters in input stream until the next
\ `[else]` or `[then]`
: [if] 0= if skipwords then ; immediate
\ `[else]` ( | ... -- ) Skip characters in input stream until the next `[then]`
: [else] skipwords ; immediate
\ `[then]` ( -- ) End of conditional block
: [then] ; immediate
\ `[defined]` ( | <word> -- f ) Pushes true or false on the stack, depending on
\ wether the next word in the input stream is currently visible in the dictionary
\ or not
: [defined] bl word find nip ; immediate
\ `[undefined]` ( | <word> -- f ) Pushes true or false on the stack, depending on
\ wether the next word in the input stream is currently invisible in the dictionary
\ or not
: [undefined] bl word find 0= nip ; immediate
\ Structure definitions
\
\ Allows for defining slightly more convenient data structures: