-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathACode.txt
1117 lines (840 loc) · 25.6 KB
/
ACode.txt
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
# This file contains the initial memory layout, with both data
# and functions. These implement the main loop, where we fetch words,
# compile and execute them.
#
# The text in this file is assembled into binary form with the CFT script
# Assembler. It contains two major functions:
#
# - t - show compiled code on still symbolic form
# - Compile - generates content to paste into Heap.h
#
# Tags
# ####
# :xxx = create tag
# 'xxx = insert tag address as LITERAL
# *xxx = insert tag address as two bytes
#
# Defines
# #######
#
# _'xxx for literal (code)
# _*xxx for inline bytes
#
# ASCII strings
# #############
#
# %t %r %u %e 0
def _'CELL LITERAL1 2 # defines cell size (Ref size) = 2
def _'REF_NULL LITERAL1 0
def _*REF_NULL 0 0
def _*ASCII_SPACE 32
def _'ASCII_SPACE LITERAL1 _*ASCII_SPACE
def _*ASCII_CR 13
def _'ASCII_CR LITERAL1 _*ASCII_CR
def _*ASCII_LF 10
def _'ASCII_LF LITERAL1 _*ASCII_LF
# Symbol Stack Entry (SSE)
# ########################
# [
# value Ref 2
# next Ref 2
# ]
# Basically a CONS cell (from Lisp)
# Allocated dynamically, linked via next ref
def _'SSE.value
def _'SSE.next LITERAL1 2 ADD
def _'SSE.n? LITERAL1 4
# Dictionary entry (DE)
# #####################
# [
# name Ref 2
# code Ref 2
# flags byte 1
# next Ref 2
# ]
# Allocated from the heap (next pointer)
def _'DE.name
def _'DE.code LITERAL1 2 ADD
def _'DE.flags LITERAL1 4 ADD
def _'DE.next LITERAL1 5 ADD
def _'DE.n? LITERAL1 7
# Status byte for DE's
def _'DE_Status_bit_regular LITERAL1 0x00
def _'DE_Status_bit_immediate LITERAL1 0x01
# Boolean constants
def _'FALSE LITERAL1 0
def _'TRUE LITERAL4 0xff 0xff 0xff 0xff
# Call Stack Frame (CSF)
# ######################
# [
# code Ref 2
# tempStackBase byte 1
# tempStackNext byte 1
# pc Ref 2
# ]
def _'CSF.code
def _'CSF.tempStackBase LITERAL1 2 ADD
def _'CSF.tempStackNext LITERAL1 3 ADD
def _'CSF.pc LITERAL1 4 ADD
# Sizes
def _*CSF.n? 6
def _'CSF.n? LITERAL1 _*CSF.n? # Size of call stack frame, to navigate the call stack
def _*CS_maxDepth 10
def _'CS_maxDepth LITERAL1 _*CS_maxDepth # max call depth
# Temp Stack Frame (TSF)
# ######################
# [
# name Ref 2
# value Long 4
# ]
def _'TSF.name
def _'TSF.value LITERAL1 2 ADD
# Sizes
def _*TSF.n? 6
def _'TSF.n? LITERAL1 _*TSF.n?
def _*TS_maxDepth 30
def _'TS_maxDepth LITERAL1 _*TS_maxDepth # number of Temp Stack Frames (TSF)
# Some pseudo instructions
# ########################
def =$0 'SYM_$0 SETLOCAL
def =$1 'SYM_$1 SETLOCAL
def =$2 'SYM_$2 SETLOCAL
def =$3 'SYM_$3 SETLOCAL
def =$4 'SYM_$4 SETLOCAL
def =$5 'SYM_$5 SETLOCAL
def =$6 'SYM_$6 SETLOCAL
def =$7 'SYM_$7 SETLOCAL
def $0 'SYM_$0 GETLOCAL
def $1 'SYM_$1 GETLOCAL
def $2 'SYM_$2 GETLOCAL
def $3 'SYM_$3 GETLOCAL
def $4 'SYM_$4 GETLOCAL
def $5 'SYM_$5 GETLOCAL
def $6 'SYM_$6 GETLOCAL
def $7 'SYM_$7 GETLOCAL
def INCR LITERAL1 1 ADD
def DECR LITERAL1 1 SUBTRACT
def INCR2 LITERAL1 2 ADD
# local variables used in defines
def =$a 'SYM_$a SETLOCAL
def =$b 'SYM_$b SETLOCAL
def =$c 'SYM_$c SETLOCAL
def =$d 'SYM_$d SETLOCAL
def $a 'SYM_$a GETLOCAL
def $b 'SYM_$b GETLOCAL
def $c 'SYM_$c GETLOCAL
def $d 'SYM_$d GETLOCAL
# Op-codes for generating code
def OP:JMP LITERAL1 0
def OP:COND_JMP LITERAL1 1
def OP:CALL LITERAL1 2
def OP:RETURN LITERAL1 3
def OP:PANIC LITERAL1 4
def OP:HEAP_MAX LITERAL1 5
def OP:TIBs LITERAL1 6
def OP:TIBr LITERAL1 7
def OP:TIBr+ LITERAL1 8
def OP:TIBs+ LITERAL1 9
def OP:TIBr< LITERAL1 10
def OP:TIBs> LITERAL1 11
def OP:TIBW LITERAL1 12
def OP:EMIT LITERAL1 13
def OP:EMITWORD LITERAL1 14
def OP:ADD LITERAL1 15
def OP:SUBTRACT LITERAL1 16
def OP:MUL LITERAL1 17
def OP:DIV LITERAL1 18
def OP:MOD LITERAL1 19
def OP:RIGHTSHIFT LITERAL1 20
def OP:LEFTSHIFT LITERAL1 21
def OP:AND LITERAL1 22
def OP:OR LITERAL1 23
def OP:NOT LITERAL1 24
def OP:EQ LITERAL1 25
def OP:NE LITERAL1 26
def OP:GT LITERAL1 27
def OP:LT LITERAL1 28
def OP:GE LITERAL1 29
def OP:LE LITERAL1 30
def OP:DROP LITERAL1 31
def OP:SETLOCAL LITERAL1 32
def OP:GETLOCAL LITERAL1 33
def OP:WORD LITERAL1 34
def OP:WRITE1 LITERAL1 35
def OP:WRITE2 LITERAL1 36
def OP:WRITE4 LITERAL1 37
def OP:READ1 LITERAL1 38
def OP:READ2 LITERAL1 39
def OP:READ4 LITERAL1 40
def OP:READ1g LITERAL1 41
def OP:WRITE1g LITERAL1 42
def OP:LITERAL1 LITERAL1 43
def OP:LITERAL2 LITERAL1 44
def OP:LITERAL4 LITERAL1 45
def OP:CHECK_PARSE LITERAL1 46
def OP:PARSE LITERAL1 47
# Byte address for jumping inside compiled code (not used in this file)
def OP:JMP1 LITERAL1 48
def OP:COND_JMP1 LITERAL1 49
def OP:DEBUG LITERAL1 50
# Programmatic control over debugging
def _DEBUG_LOG LITERAL1 1 DEBUG
def _DEBUG_LOG_STEP LITERAL1 2 DEBUG
def _DEBUG_OFF LITERAL1 0 DEBUG
# Memory layout
#
# From this point we create tags and refer them, in order to do
# function calls. The CALL operation is written in C, and manipulates
# the Call Stack (CS)
# ###############################################################################
0 # this position is the null-pointer address (not used)
:MAIN_SETUP *MainSetup # call this first
:MAIN_LOOP *MainLoop # then this, also after runtime PANIC
# Call stack
:CS_BASE_REF *CS_DATA # call stack base on heap
:CS_NEXT_FRAME 0 # index of next callstack frame (0-based)
# Symbol stack
:SYM_TOP_REF *SYM_Cons_List # symbol table has initial hard coded content
# Temp stack
:TS_BASE_REF *TEMP_STACK_DATA # reserved data area
# Compile buf pointer
:CompileBufPos 0 # Single byte
# Dictionary pointer
:DICT_TOP _*REF_NULL # ref to first Dictionary Entry DE
# Heap management
:HERE *END_MARKER # two byte Ref to next free byte on heap
:HERE_SHADOW *END_MARKER # used by main loop, to rollback heap if panic
# This marker is the beginning of the area of the heap that is not allowed to be
:BEGIN-STATIC-DATA
# Sizes for statically allocated blocks (on heap)
:CS_MAX_DEPTH _*CS_maxDepth # byte = number of frames
:TS_MAX_DEPTH _*TS_maxDepth # byte = number of frames
# Protected areas of the heap
:HEAP_STATICDATA_BEGIN *BEGIN-STATIC-DATA
:HEAP_STATICDATA_END *END-STATIC-DATA
# Forth primitives
# --
:Malloc # n -- ptr # Sets all allocated bytes to zero
=$0 # n
'HERE READ2 =$1 # ptr
$1 $0 ADD 'HERE WRITE2 # HERE = HERE + n
# zero all bytes in allocated memory
# --
$1 =$2 # copy pointer, for loop
:xMalloc_clear_loop
$2 'HERE READ2 EQ
'xMalloc_clear_end COND_JMP
LITERAL1 0 $2 WRITE1
$2 LITERAL1 1 ADD =$2
'xMalloc_clear_loop JMP
:xMalloc_clear_end
$1 # return ptr
RETURN
:Memcpy # ( targetRef srcRef count -- )
=$1 # count
=$2 # srcRef
=$3 # targetRef
:xMemcpy_loop
$1 LITERAL1 0 LE
'xMemcpy_complete COND_JMP # if count==0 goto complete
$2 $1 ADD READ1 # source byte
$3 $1 ADD WRITE1 # target write
$1 LITERAL1 1 SUBTRACT =$1
'xMemcpy_loop JMP
:xMemcpy_complete
RETURN
:HereWord
'HERE # save HERE reference on stack
RETURN
:HereCommit # update HERE_SHADOW to HERE
'HERE READ2 'HERE_SHADOW WRITE2
RETURN
:CSF_current # returns pointer to current CSF (call stack frame)
'CS_NEXT_FRAME READ1
LITERAL1 0 EQ
'xCSFc_underflow COND_JMP
'CS_BASE_REF READ2
'CS_NEXT_FRAME READ1 _'CSF.n? MUL
ADD
RETURN
:xCSFc_underflow
'SYM_CSF_Underflow 'PANIC CALL
:OutByte # ( byte -- ) write to CompileBuf
=$0 # byte
'CompileBufPos READ1 =$1 #
$1 LITERAL1 254 GE
'xOutByte_fail COND_JMP
$0 'CompileBuf $1 ADD WRITE1
$1 INCR 'CompileBufPos WRITE1
RETURN
:xOutByte_fail
'SYM_OutByte-Overflow 'PANIC CALL
RETURN
:OutRef # ( Ref -- ) write to CompileBuf
=$0
OP:LITERAL2 'OutByte CALL
$0 LITERAL1 8 RIGHTSHIFT 'OutByte CALL
$0 'OutByte CALL
RETURN
:FirstNonSpace # move TIBs to first non-space character
:xFNS_loop
TIBs _'ASCII_SPACE NE
'xFNS_ok COND_JMP
TIBs+
'xFNS_loop JMP
:xFNS_ok
RETURN
:FirstSpace # Move TIBr ahead to first space character
TIBr<
:xFS_loop
TIBr _'ASCII_SPACE EQ
'xFS_ok COND_JMP
TIBr+
'xFS_loop JMP
:xFS_ok
RETURN
:DE_create # name -- dictEntry # Create DE and push on dictionary stack
=$0 # $0 = name
_'DE.n? 'Malloc CALL =$1 # $1 = ptr to DE
$0 $1 _'DE.name WRITE2 # DE.name=name
'DICT_TOP READ2 $1 _'DE.next WRITE2 # DE.next=Dict_top
$1 'DICT_TOP WRITE2 # Dict_top=DE
$1 # return ptr
RETURN
:CREATE # Calls 'DE_create after obtaining 'NextWord
'NextWord CALL 'DE_create CALL
DROP # drop return value from 'DE_create
RETURN
:NextWord # ( -- wordRef )
'FirstNonSpace CALL # set TIBs
'FirstSpace CALL # advance TIBr
TIBW =$0 # create word from TIBs up to byte before TIBr
TIBs> # advance TIBs to TIBr
$0 # return word
RETURN
:COLON # The colon compiler
# Reset CompileBuf
LITERAL1 0 'CompileBufPos WRITE1
'NextWord CALL 'DE_create CALL =$1 # dictionary entry
:xCOLON_LOOP
'FirstNonSpace CALL
'FirstSpace CALL
TIBW =$2 # next word
$2 'SYM_SEMICOLON EQ
'xCOLON_end COND_JMP # if semicolon, end loop
$2 'CompileWord CALL
:xCOLON_end
OP:RETURN 'OutByte CALL
RETURN
:IF
OP:NOT 'OutByte CALL # if not ... then jump ahead
'CompileBufPos READ1 =$0 # $0 = cond-jmp byte
0 'OutByte CALL # dummy jump target
OP:COND_JMP1 'OutByte CALL
:xIF_loop
'NextWord CALL =$1 # $1 = next word
$1 'SYM_THEN EQ
'xIF_then COND_JMP
$1 'SYM_ELSE EQ
'xIF_else COND_JMP
$1 'SYM_SEMICOLON EQ
'xIF_panic COND_JMP
$1 'CompileWord CALL
'xIF_loop JMP
:xIF_then
# patch current pos into $0 (if-not) jump
'CompileBufPos READ1
'CompileBuf READ2 $0 ADD
WRITE1
RETURN
:xIF_else
# generate unconditional JMP to THEN
'CompileBufPos READ1 =$2 # $2 = (if not else) jmp ahead
0 'OutByte CALL # dummy jump target
OP:JMP1 'OutByte CALL
# start else-code, patch current pos into $0 (if-not) jump
'CompileBufPos READ1
'CompileBuf READ2 $0 ADD
WRITE1
$2 =$0 # reusing the :xIF_then, $0 is now the byte to patch
:xIF_else_loop # look for THEN
'NextWord CALL =$1
$1 'SYM_THEN EQ
'xIF_then COND_JMP
$1 'SYM_SEMICOLON EQ
'xIF_panic COND_JMP
$1 'CompileWord CALL
'xIF_else_loop JMP
:xIF_panic
'SYM_Unterminated_if 'PANIC CALL
:LOOP
'CompileBufPos READ1 =$0 # $0 = top of loop
:xLOOP_next_word
'NextWord CALL =$1 # $1 = next word
$1 'SYM_SEMICOLON EQ
'xLOOP_panic COND_JMP
$1 'SYM_Next? EQ
'xLOOP_next? COND_JMP
$1 'CompileWord CALL
:xLOOP_next?
OP:NOT 'OutByte CALL # if value on stack is false, then
'CompileBufPos READ1
LITERAL1 4 # (after-loop-pc) COND_JMP1 ($0) JMP1 --> HERE (after-loop-pc!)
ADD
'OutByte CALL # (after-loop-pc) # byte 1
OP:COND_JMP1 'OutByte CALL # COND_JMP1 # byte 2
$0 'OutByte CALL # $0 # byte 3
OP:JMP1 'OutByte CALL # JMP1 # byte 4
RETURN
:xLOOP_panic
'SYM_Unterminated_loop 'PANIC CALL
:Immediate # Set immediate flag on newest dictionary entry
'DICT_TOP READ2 =$1 # ptr to topmost DE
$1 LITERAL1 0 NE
'xImmediate_ok COND_JMP
'SYM_Immediate_no_word 'PANIC CALL
:xImmediate_ok
$1 _'DE.flags READ1 =$2 # flags byte
$2 _'DE_Status_bit_immediate OR =$2 # update flags value
$2 $1 _'DE.flags WRITE1 # write updated flags to DE.flags
RETURN
:DOT
65 EMIT # "a"
RETURN
:CR
_'ASCII_CR EMIT
_'ASCII_LF EMIT
RETURN
def OUTRETURN =$a NE 'xSIW_@@ COND_JMP $a 'OutByte CALL _'TRUE RETURN :xSIW_@@
# $a = opcode
# NE compares $a and 'SYM_XXX, jumps to end of line if not matching
# if match, call OutByte with $d, then return true
# Compile single instruction words
:SingleInstructionWords # ( word -- bool )
=$0
# TODO: add TIB* and others that we want to be part of the Forth language
$0 'SYM_RETURN OP:RETURN OUTRETURN
$0 'SYM_PANIC OP:PANIC OUTRETURN
$0 'SYM_HEAP_MAX OP:HEAP_MAX OUTRETURN
$0 'SYM_TIBs OP:TIBs OUTRETURN
$0 'SYM_TIBr OP:TIBr OUTRETURN
$0 'SYM_TIBr+ OP:TIBr+ OUTRETURN
$0 'SYM_TIBs+ OP:TIBs+ OUTRETURN
$0 'SYM_TIBr< OP:TIBr< OUTRETURN
$0 'SYM_TIBs> OP:TIBs> OUTRETURN
$0 'SYM_TIBW OP:TIBW OUTRETURN
$0 'SYM_EMIT OP:EMIT OUTRETURN
$0 'SYM_EMITWORD OP:EMITWORD OUTRETURN
$0 'SYM_DROP OP:DROP OUTRETURN
$0 'SYM_WRITE1 OP:WRITE1 OUTRETURN
$0 'SYM_WRITE2 OP:WRITE2 OUTRETURN
$0 'SYM_WRITE4 OP:WRITE4 OUTRETURN
$0 'SYM_READ1 OP:READ1 OUTRETURN
$0 'SYM_READ2 OP:READ2 OUTRETURN
$0 'SYM_READ4 OP:READ4 OUTRETURN
$0 'SYM_READ1g OP:READ1g OUTRETURN
$0 'SYM_WRITE1g OP:WRITE1g OUTRETURN
$0 'SYM_CHECK_PARSE OP:CHECK_PARSE OUTRETURN
$0 'SYM_PARSE OP:PARSE OUTRETURN
$0 'SYM_ADD OP:ADD OUTRETURN
$0 'SYM_SUBTRACT OP:SUBTRACT OUTRETURN
$0 'SYM_MUL OP:MUL OUTRETURN
$0 'SYM_DIV OP:DIV OUTRETURN
$0 'SYM_MOD OP:MOD OUTRETURN
$0 'SYM_RIGHTSHIFT OP:RIGHTSHIFT OUTRETURN
$0 'SYM_LEFTSHIFT OP:LEFTSHIFT OUTRETURN
$0 'SYM_AND OP:AND OUTRETURN
$0 'SYM_OR OP:OR OUTRETURN
$0 'SYM_NOT OP:NOT OUTRETURN
$0 'SYM_EQ OP:EQ OUTRETURN
$0 'SYM_NE OP:NE OUTRETURN
$0 'SYM_GT OP:GT OUTRETURN
$0 'SYM_LT OP:LT OUTRETURN
$0 'SYM_GE OP:GE OUTRETURN
$0 'SYM_LE OP:LE OUTRETURN
_'FALSE
RETURN
# Compile general word. Called from COLON (and others).
# Does not recognize COLON or SEMICOLON.
:CompileWord # ( word -- )
=$0 # The word
# Check if number
$0 CHECK_PARSE NOT 'xCOMP_not_number COND_JMP
$0 'CompileNumber CALL
RETURN
:xCOMP_not_number
# Check if local variable set or get, returns true or false
$0 'CompileLocalVariables CALL 'xCOMP_done COND_JMP
# Check words that map directly to instruction
$0 'SingleInstructionWords CALL NOT 'xCompileNotSIW COND_JMP
RETURN
:xCompileNotSIW
# Check if defined in dictionary
$0 'DictLookup CALL =$1 # $1 = DE or NULL
$1 _'REF_NULL EQ
'xCOMP_fail COND_JMP
# Dictionary word found
$1 _'DE.code =$2 # code pointer
$1 _'DE.flags READ1 _'DE_Status_bit_immediate AND NOT
'xCOMP_regular COND_JMP
# immediate word, call it right now
$2 CALL
RETURN
:xCOMP_regular
# Generate code for call
$2 'OutRef CALL
OP:CALL 'OutByte CALL
:xCOMP_done
RETURN
:xCOMP_fail
'SYM_invalid_word EMITWORD
LITERAL1 %: EMIT
_'ASCII_SPACE EMIT
$0 EMITWORD
_'ASCII_CR EMIT
_'ASCII_LF EMIT
'SYM_invalid_word 'PANIC CALL
:CompileLocalVariables # ( word -- bool )
=$0 # $0 = the word
$0 READ1 LITERAL1 %$ EQ
$0 INCR READ1 LITERAL1 0 NE AND
'xCLV_get COND_JMP
$0 READ1 LITERAL1 %= EQ
$0 INCR READ1 LITERAL1 %$ EQ AND
$0 INCR2 READ1 LITERAL1 0 NE AND
'xCLV_set COND_JMP
_'FALSE # Not local variable expr
RETURN
:xCLV_get
# Using $nnn as name for local variable, so using $0 here
$0 'OutRef CALL
OP:GETLOCAL 'OutByte CALL
_'TRUE
RETURN
:xCLV_set
# Isolate the $nnn part, by skipping first character than creating separate word
$0 LITERAL1 1 ADD WORD 'OutRef CALL
OP:SETLOCAL 'OutByte CALL
_'TRUE
RETURN
:CompileNumber # ( number -- )
=$0 # the number
$0 LITERAL4 0xff 0xff 0x00 0x00 AND
'xCN_4 COND_JMP
$0 LITERAL4 0x00 0x00 0xff 0x00 AND
'xCN_2 COND_JMP
# 1 byte literal
OP:LITERAL1 'OutByte CALL
$0 'OutByte CALL
RETURN
:xCN_2
# 2 byte literal
OP:LITERAL2 'OutByte CALL
$0 LITERAL1 8 RIGHTSHIFT 'OutByte CALL
$0 'OutByte CALL
RETURN
:xCN_4
# 4 byte literal
OP:LITERAL4 'OutByte CALL
$0 LITERAL1 24 RIGHTSHIFT 'OutByte CALL
$0 LITERAL1 16 RIGHTSHIFT 'OutByte CALL
$0 LITERAL1 8 RIGHTSHIFT 'OutByte CALL
$0 'OutByte CALL
RETURN
:IsInt # ( word -- bool )
CHECK_PARSE
RETURN
:ParseInt # ( word -- number )
PARSE # OP:PARSE may PANIC - check with IsInt first if in doubt
RETURN
:DictLookup # ( wordRef -- ref ) returns _'REF_NULL or pointer to dict entry
=$0 # name we are looking for
'DICT_TOP READ2 =$1 # ptr = top dictionary entry (or null)
:xDL_loop
$1 _'REF_NULL EQ 'xDL_fail COND_JMP # if ptr == REF_NULL goto 'DL_fail
$1 _'DE.name READ2 $0 EQ 'xDL_ok COND_JMP # if $0.name == name GOTO 'DL_ok
$1 _'DE.next READ2 =$1 # ptr = ptr.next
'xDL_loop JMP # repeat
:xDL_fail
_'REF_NULL
LITERAL1 %N EMIT
RETURN
:xDL_ok
$1 # return ptr (to dictionary entry)
LITERAL1 %Y EMIT
RETURN
:PANIC # ( errorSymbol -- )
PANIC
# reset input buffer
# clear data- and call stack
# then call :MainLoop
RETURN
:DictAdd # ( name flags code -- )
=$2 # code
=$1 # flags
=$0 # name
$0 EMITWORD
_'ASCII_CR EMIT
_'ASCII_LF EMIT
$0 'DE_create CALL =$7 # ptr to DE
$1 $7 _'DE.flags WRITE1 # DE.flags=flags
$2 $7 _'DE.code WRITE2 # DE.code=code
RETURN
def Immediate _'DE_Status_bit_immediate
def Regular _'DE_Status_bit_regular
:MainSetup # Call first time after boot or after hard Reset
# Set HERE to byte following this memory map
'END_MARKER 'HERE WRITE2
'HereCommit CALL # Update HERE_SHADOW to match HERE
## SHOULD FAIL!
## (it did :-)
#LITERAL1 3
# LITERAL1 200 WRITE1
# Initial dictionary with words that can be called from Forth
# mainly during compilation, hence immediate
# name Flags Code
# -------------------------------------------------
'SYM_COLON Immediate 'COLON 'DictAdd CALL
'SYM_IF Immediate 'IF 'DictAdd CALL
'SYM_LOOP Immediate 'LOOP 'DictAdd CALL
'SYM_IMMEDIATE Immediate 'Immediate 'DictAdd CALL
'SYM_HERE Regular 'HereWord 'DictAdd CALL
'SYM_DOT Regular 'DOT 'DictAdd CALL
'SYM_cr Regular 'CR 'DictAdd CALL
'SYM_MALLOC Regular 'Malloc 'DictAdd CALL
'SYM_CREATE Immediate 'CREATE 'DictAdd CALL
'SYM_DictLookup Regular 'DictLookup 'DictAdd CALL
'SYM_OutByte Regular 'OutByte 'DictAdd CALL
'SYM_OutRef Regular 'OutRef 'DictAdd CALL
'SYM_Compile Immediate 'CompileWord 'DictAdd CALL
'SYM_NextWord Regular 'NextWord 'DictAdd CALL
'SYM_IsInt Regular 'IsInt 'DictAdd CALL
'SYM_ParseInt Regular 'ParseInt 'DictAdd CALL
'SYM_PANIC Regular 'PANIC 'DictAdd CALL
# Commit the memory allocated for the above
'HereCommit CALL
RETURN
# Main loop is called after MainSetup, and again on PANIC, as it contains
# code to clean up after a panic (when HERE_SHADOW < HERE)
:MainLoop
# If HERE_SHADOW != HERE, then we have arrived here
# as a restart after a PANIC.
'HERE_SHADOW READ2 =$0 # $0 = HERE-shadow
'HERE READ2 =$1 # $1 = HERE
$1 $0 EQ 'xML_Loop COND_JMP # if HERE == HERE-shadow, goto ok
'SYM_cleanup_after_panic EMITWORD
_'ASCII_CR EMIT
_'ASCII_LF EMIT
# remove entries from dictionary until DE ref
# smaller than HERE-shadow, which means they were
# allocated before code that now has panicked
'DICT_TOP READ2 =$2 # $2 = DE pointer
:xML_DictPurge
$2 $0 LT 'xML_DictPurgeOk COND_JMP # includes NULL
$2 _'DE.next READ2 =$2 # ptr=ptr.next
'xML_DictPurge JMP
:xML_DictPurgeOk
$2 'DICT_TOP WRITE2 # update DICT_TOP
# doing the same for symbol table
'SYM_TOP_REF READ2 =$2 # $2 = Cons pointer
:xML_SymPurge
$2 $0 LT 'xML_SymPurgeOk COND_JMP
$2 LITERAL1 2 ADD READ2 =$2 # ptr=ptr.next
'xML_SymPurge JMP
:xML_SymPurgeOk
$2 'SYM_TOP_REF WRITE2 # update SYM_TOP
# The actual main loop
:xML_Loop
'SYM_ok EMITWORD
# reset compile buffer
LITERAL1 0 'CompileBufPos WRITE1
# Locate word, then compile it
'NextWord CALL =$0
$0 'CompileWord CALL
# Add return to CompileBuf
OP:RETURN 'OutByte CALL
# Run code in CompileBuf
_DEBUG_LOG_STEP
'CompileBuf CALL
_DEBUG_OFF
# If there was a panic, we never reach this line, so getting here means
# the word was ok. We commit the heap changes before repeating the loop
'HereCommit CALL
'xML_Loop JMP
:SYM_Cons_List # hard coded list of symbols
# New symbols will be added from C, mostly from TIBW or WORD ops
# Note NEXT and NO_NEXT are implemented in the Assembler
*SYM_$0 NEXT
*SYM_$1 NEXT
*SYM_$2 NEXT
*SYM_$3 NEXT
*SYM_$4 NEXT
*SYM_$5 NEXT
*SYM_$6 NEXT
*SYM_$7 NEXT
*SYM_$a NEXT
*SYM_$b NEXT
*SYM_$c NEXT
*SYM_$d NEXT
*SYM_RETURN NEXT
*SYM_PANIC NEXT
*SYM_HEAP_MAX NEXT
*SYM_TIBs NEXT
*SYM_TIBr NEXT
*SYM_TIBr+ NEXT
*SYM_TIBs+ NEXT
*SYM_TIBr< NEXT
*SYM_TIBs> NEXT
*SYM_TIBW NEXT
*SYM_EMIT NEXT
*SYM_EMITWORD NEXT
*SYM_DROP NEXT
*SYM_WRITE1 NEXT
*SYM_WRITE2 NEXT
*SYM_WRITE4 NEXT
*SYM_READ1 NEXT
*SYM_READ2 NEXT
*SYM_READ4 NEXT
*SYM_READ1g NEXT
*SYM_WRITE1g NEXT
*SYM_CHECK_PARSE NEXT
*SYM_PARSE NEXT
*SYM_ADD NEXT
*SYM_SUBTRACT NEXT
*SYM_MUL NEXT
*SYM_DIV NEXT
*SYM_MOD NEXT
*SYM_RIGHTSHIFT NEXT
*SYM_LEFTSHIFT NEXT
*SYM_AND NEXT
*SYM_OR NEXT
*SYM_NOT NEXT
*SYM_EQ NEXT
*SYM_NE NEXT
*SYM_GT NEXT
*SYM_LT NEXT
*SYM_GE NEXT
*SYM_LE NEXT
*SYM_COLON NEXT
*SYM_SEMICOLON NEXT
*SYM_IF NEXT
*SYM_THEN NEXT
*SYM_ELSE NEXT
*SYM_LOOP NEXT
*SYM_Next? NEXT
*SYM_IMMEDIATE NEXT
*SYM_HERE NEXT
*SYM_DOT NEXT
*SYM_cr NEXT
*SYM_MALLOC NEXT
*SYM_CREATE NEXT
*SYM_DictLookup NEXT
*SYM_OutByte NEXT
*SYM_OutRef NEXT
*SYM_Compile NEXT
*SYM_NextWord NEXT
*SYM_ParseInt NEXT
*SYM_IsInt NEXT
*SYM_ok NEXT
*SYM_invalid_word NEXT
*SYM_cleanup_after_panic NEXT
*SYM_CSF_Underflow NEXT
*SYM_Immediate_no_word NEXT
*SYM_Unknown-Word NEXT
*SYM_Unterminated_if NEXT
*SYM_OutByte-Overflow NO_NEXT
:SYM_$0 %$ %0 0
:SYM_$1 %$ %1 0