-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathcompile.lua
executable file
·1627 lines (1439 loc) · 45.6 KB
/
compile.lua
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
#!tools/lua
-- Ace Forth cross compiler
-- Copyright (c) 2021 Petri Häkkinen
-- See LICENSE file for details
--
-- Each user defined word has the following structure:
-- Name array of bytes, the last character has high bit set which marks the end of string
-- Word length short, the length of the word in bytes excluding the name
-- Link pointer to name length field of previous defined word
-- Name length byte, length of name in bytes
-- Code field machine code address, called when the word is executed (for example, DO_COLON or DO_PARAM)
-- Parameter field optional area for storing word specific data (compiled forth code for DO_COLON words)
--
-- The first user defined word is placed at 3C51 in RAM.
-- The function create_word() below adds a new word header to the output dictionary.
local mcode = require "mcode"
local DO_COLON = 0x0EC3 -- DoColon routine in ROM, the value of code field for user defined words
local DO_PARAM = 0x0FF0 -- Routine which pushes the parameter field to stack, code field value for variables
local DO_CONSTANT = 0x0FF5 -- Routine which pushes short from parameter field to stack, code field value for constants
local FORTH_END = 0x04B6 -- Internal word, returns from current word
local PUSH_BYTE = 0x104B -- Internal word, pushes the following literal byte to stack
local PUSH_WORD = 0x1011 -- Internal word, pushes the following literal word to stack
local PUSH_ZERO = 0x0688 -- Internal word, push zero stack
local CBRANCH = 0x1283 -- Internal word, conditional branch '?branch', the following word is the branch offset
local BRANCH = 0x1276 -- Internal word, unconditional branch 'branch', the following word is the branch offset
local PRINT = 0x1396 -- Internal word, prints a string, string length word + data follows
local DO = 0x1323 -- Internal word, runtime part of DO (pushes 2 values from data stack to return stack)
local LOOP = 0x1332 -- Internal word, runtime part of LOOP, the following word is the branch offset
local PLUS_LOOP = 0x133C -- Internal word, runtime part of +LOOP, the following word is the branch offset
local POSTPONE = 0x0001 -- Internal word, hacky way to postpone compilation of words, not actual ROM code!
local start_address = 0x3c51
local v_current = 0x3C4C
local v_context = 0x3C4C
local v_voclink = 0x3C4F
-- parse args
local args = {...}
local input_files = {}
local output_file
opts = { main_word = "main", tap_filename = "dict" }
function fatal_error(msg)
io.stderr:write(msg, "\n")
os.exit(-1)
end
do
local i = 1
while i <= #args do
local arg = args[i]
if string.match(arg, "^%-") then
if arg == "--minimal-word-names" then
opts.minimal_word_names = true
elseif arg == "--inline" then
opts.inline_words = true
elseif arg == "--eliminate-unused-words" then
opts.eliminate_unused_words = true
elseif arg == "--small-literals" then
opts.small_literals = true
elseif arg == "--tail-call" then
opts.tail_call = true
elseif arg == "--short-branches" then
opts.short_branches = true
elseif arg == "--optimize" then
opts.inline_words = true
opts.minimal_word_names = true
opts.eliminate_unused_words = true
opts.small_literals = true
opts.tail_call = true
opts.short_branches = true
elseif arg == "--verbose" then
opts.verbose = true
elseif arg == "--ignore-case" then
opts.ignore_case = true
elseif arg == "--no-warn" then
opts.no_warn = true
elseif arg == "--mcode" then
opts.mcode = true
elseif arg == "--main" then
i = i + 1
opts.main_word = args[i]
if opts.main_word == nil then fatal_error("Word name must follow --main") end
elseif arg == "--filename" then
i = i + 1
opts.tap_filename = args[i]
if opts.tap_filename == nil then fatal_error("TAP filename must follow --filename") end
if #opts.tap_filename > 10 then fatal_error("TAP filename too long (max 10 chars)") end
elseif arg == "-o" then
i = i + 1
output_file = args[i]
if output_file == nil then fatal_error("Output filename must follow -o") end
elseif arg == "-l" then
i = i + 1
opts.listing_file = args[i]
if opts.listing_file == nil then fatal_error("Listing filename must follow -l") end
else
fatal_error("Invalid option: " .. arg)
end
else
input_files[#input_files + 1] = arg
end
i = i + 1
end
end
if #input_files == 0 then
print("Usage: compile.lua [options] <inputfile1> <inputfile2> ...")
print("\nOptions:")
print(" -o <filename> Sets output filename")
print(" -l <filename> Write listing to file")
print(" --mcode Compile to machine code")
print(" --ignore-case Treat all word names as case insensitive")
print(" --no-warn Disable all warnings")
print(" --verbose Print information while compiling")
print(" --main <name> Sets name of main executable word (default 'main')")
print(" --filename <name> Sets the filename for tap header (default 'dict')")
print("\nOptimizations:")
print(" --optimize Enable all optimizations")
print(" --minimal-word-names Rename all words as '@', except main word")
print(" --inline Inline words that are used only once")
print(" --eliminate-unused-words Eliminate unused words when possible")
print(" --small-literals Optimize byte-sized literals")
print(" --tail-call Optimize tail calls (mcode only)")
print(" --short-branches Use relative branches when possible (mcode only)")
os.exit(-1)
end
function verbose(...)
if opts.verbose then
print(string.format(...))
end
end
local pass = 1
eliminate_words = {}
inline_words = {}
::restart::
verbose("Pass %d", pass)
local input -- source code as string
local input_file -- current input filename
local cur_pos -- current position in input
local cur_line -- current line in input
local compile_mode = false -- interpret or compile mode?
local inside_definition = false -- are we inside CODE or CREATE definition?
local prev_compile_mode -- previous value of compile_mode (before [ was invoked)
local stack = {} -- the compiler stack
local mem = { [0] = 10 } -- compiler memory
local output_pos = start_address -- current output position in the dictionary
local next_immediate_word = 1 -- next free address for compiled immediate words
local labels = {} -- label -> address for current word
local gotos = {} -- address to be patched -> label for current word
local last_word -- name of last user defined word
local word_counts = {} -- how many times each word is used in generated code?
local word_flags = {} -- bitfield of F_* flags
local list_headers = {} -- listing headers (addr -> string)
local list_lines = {} -- listing lines (addr -> string)
local list_comments = {} -- listing comments (addr -> string)
local dont_allow_redefining = false -- if set, do not allow redefining word behaviors (hack for library words)
local warnings = {} -- array of strings
-- address of prev word's name length field in RAM
-- initial value: address of FORTH in RAM
local prev_word_link = 0x3C49
-- should we run another pass after this one?
more_work = false
rom_words = {
FORTH = 0x3c4a, UFLOAT = 0x1d59, INT = 0x1d22, FNEGATE = 0x1d0f, ["F/"] = 0x1c7b, ["F*"] = 0x1c4b,
["F+"] = 0x1bb1, ["F-"] = 0x1ba4, LOAD = 0x198a, BVERIFY = 0x1979, VERIFY = 0x1967, BLOAD = 0x1954,
BSAVE = 0x1944, SAVE = 0x1934, LIST = 0x1670, EDIT = 0x165e, FORGET = 0x1638, REDEFINE = 0x13fd,
EXIT = 0x13f0, [".\""] = 0x1388, ["("] = 0x1361, ["["] = 0x13d5, ["+LOOP"] = 0x12d0, LOOP = 0x12bd,
DO = 0x12ab, UNTIL = 0x1263, REPEAT = 0x124c, BEGIN = 0x121a, THEN = 0x1207, ELSE = 0x11ec,
WHILE = 0x11d5, IF = 0x11c0, ["]"] = 0x13e1, LEAVE = 0x1316, J = 0x1302, ["I'"] = 0x12f7, I = 0x12e9,
DEFINITIONS = 0x11ab, VOCABULARY = 0x117d, IMMEDIATE = 0x1160, ["RUNS>"] = 0x1125, ["DOES>"] = 0x10b4,
COMPILER = 0x10f5, CALL = 0x10a7, DEFINER = 0x1074, ASCII = 0x1028, LITERAL = 0x1006, CONSTANT = 0x0fe2,
VARIABLE = 0x0fcf, ALLOT = 0x0f76, ["C,"] = 0x0f5f, [","] = 0x0f4e, CREATE = 0x0ed0, [":"] = 0x0eaf,
DECIMAL = 0x0ea3, MIN = 0x0e87, MAX = 0x0e75, XOR = 0x0e60, AND = 0x0e4b, OR = 0x0e36, ["2-"] = 0x0e29,
["1-"] = 0x0e1f, ["2+"] = 0x0e13, ["1+"] = 0x0e09, ["D+"] = 0x0dee, ["-"] = 0x0de1, ["+"] = 0x0dd2,
DNEGATE = 0x0dba, NEGATE = 0x0da9, ["U/MOD"] = 0x0d8c, ["*/"] = 0x0d7a, ["*"] = 0x0d6d, MOD = 0x0d61,
["/"] = 0x0d51, ["*/MOD"] = 0x0d31, ["/MOD"] = 0x0d00, ["U*"] = 0x0ca8, ["D<"] = 0x0c83, ["U<"] = 0x0c72,
["<"] = 0x0c65, [">"] = 0x0c56, ["="] = 0x0c4a, ["0>"] = 0x0c3a, ["0<"] = 0x0c2e, ["0="] = 0x0c1a,
ABS = 0x0c0d, OUT = 0x0bfd, IN = 0x0beb, INKEY = 0x0bdb, BEEP = 0x0b98, PLOT = 0x0b4a, AT = 0x0b19,
["F."] = 0x0aaf, EMIT = 0x0aa3, CR = 0x0a95, SPACES = 0x0a83, SPACE = 0x0a73, HOLD = 0x0a5c, CLS = 0x0a1d,
["#"] = 0x09f7, ["#S"] = 0x09e1, ["U."] = 0x09d0, ["."] = 0x09b3, SIGN = 0x0a4a, ["#>"] = 0x099c,
["<#"] = 0x098d, TYPE = 0x096e, ROLL = 0x0933, PICK = 0x0925, OVER = 0x0912, ROT = 0x08ff, ["?DUP"] = 0x08ee,
["R>"] = 0x08df, [">R"] = 0x08d2, ["!"] = 0x08c1, ["@"] = 0x08b3, ["C!"] = 0x08a5, ["C@"] = 0x0896,
SWAP = 0x0885, DROP = 0x0879, DUP = 0x086b, SLOW = 0x0846, FAST = 0x0837, INVIS = 0x0828, VIS = 0x0818,
CONVERT = 0x078a, NUMBER = 0x06a9, EXECUTE = 0x069a, FIND = 0x063d, VLIST = 0x062d, WORD = 0x05ab,
RETYPE = 0x0578, QUERY = 0x058c, LINE = 0x0506, [";"] = 0x04a1, PAD = 0x0499, BASE = 0x048a,
CURRENT = 0x0480, CONTEXT = 0x0473, HERE = 0x0460, ABORT = 0x00ab, QUIT = 0x0099
}
-- word flags
F_NO_INLINE = 0x01 -- words that should never we inlined (explicitly marked as 'noinline' or cannot be inlined)
F_NO_ELIMINATE = 0x02 -- words that should not be eliminated even when they are not used
F_HAS_SIDE_EXITS = 0x04 -- words that have side-exits and cannot there be inlined
F_INVISIBLE = 0x08 -- word cannot be seen from user written code
F_MACRO = 0x10 -- word is a macro (to be executed immediately at compile time)
F_FORCE_INLINE = 0x20 -- word has been marked with 'inline'
-- starting addresses of user defined words
local word_start_addresses = {}
-- compilation addresses of user defined words
compilation_addresses = {}
-- inverse mapping of compilation addresses back to word names (for executing compiled code)
local compilation_addr_to_name = {}
-- Return stack for executing compile time code
local return_stack = {}
local function r_push(x)
return_stack[#return_stack + 1] = x
end
local function r_pop()
local x = return_stack[#return_stack]
comp_assert(x, "return stack underflow")
return_stack[#return_stack] = nil
return x
end
function r_peek(idx)
local v = return_stack[#return_stack + idx + 1]
comp_assert(v, "return stack underflow")
return v
end
-- Separate stack for control flow constructs
local control_flow_stack = {}
function cf_push(x)
control_flow_stack[#control_flow_stack + 1] = x
end
function cf_pop(x)
local x = control_flow_stack[#control_flow_stack]
comp_assert(x ~= nil, "control flow stack underflow")
control_flow_stack[#control_flow_stack] = nil
return x
end
-- Checks that the control flow stack is empty at the end of word definition,
-- and if not, raises an appropriate error.
function check_control_flow_stack()
local v = control_flow_stack[#control_flow_stack]
if v == "if" then
comp_error("IF without matching THEN")
elseif v == "begin" then
comp_error("BEGIN without matching UNTIL or AGAIN")
elseif v == "do" then
comp_error("DO without matching LOOP")
elseif v then
comp_error("unbalanced control flow constructs")
end
end
function printf(...)
print(string.format(...))
end
function comp_error(...)
printf("%s:%d: %s", input_file, cur_line, string.format(...))
os.exit(-1)
end
function comp_assert(expr, message)
if not expr then
comp_error("%s", message)
end
return expr
end
function warn(...)
if not opts.no_warn then
warnings[#warnings + 1] = string.format("%s:%d: Warning! %s", input_file, cur_line, string.format(...))
end
end
function push(v)
stack[#stack + 1] = v
end
function push_bool(v)
stack[#stack + 1] = v and 1 or 0
end
function pop()
local v = stack[#stack]
comp_assert(v, "compiler stack underflow")
stack[#stack] = nil
return v
end
function pop2()
local a = pop()
local b = pop()
return b, a
end
function peek(idx)
local v = stack[#stack + idx + 1]
comp_assert(v, "compiler stack underflow")
return v
end
function remove(idx)
comp_assert(stack[#stack + idx + 1], "compiler stack underflow")
table.remove(stack, #stack + idx + 1)
end
function peek_char()
local char = input:sub(cur_pos, cur_pos)
if #char == 0 then char = nil end
return char
end
-- Returns next character from input. Returns nil at end of input.
function next_char()
local char = peek_char()
if char == '\n' then cur_line = cur_line + 1 end
cur_pos = cur_pos + 1
return char
end
-- Returns the next whitespace delimited symbol from input. Returns nil at end of input.
function next_symbol()
-- skip leading whitespaces
while true do
local char = peek_char()
if char == ' ' or char == '\n' or char == '\t' then
next_char()
else
break
end
end
-- end of file reached?
if peek_char() == nil then return nil end
-- scan for next whitespace character
local start = cur_pos
while true do
local char = next_char()
if char == ' ' or char == '\n' or char == '\t' or char == nil then
return input:sub(start, cur_pos - 2)
end
end
end
-- Returns the next symbol up until next occurrence of given delimiter.
-- Returns nil at the end of input.
function next_symbol_with_delimiter(delimiter)
local start = cur_pos
while true do
local char = next_char()
if char == delimiter then
return input:sub(start, cur_pos - 2)
elseif char == nil then
return nil
end
end
end
function next_word(allow_eof)
local word = next_symbol()
if word == nil and not allow_eof then comp_error("unexpected end of file") end
if opts.ignore_case and word then word = string.upper(word) end
return word
end
function next_number()
local sym = next_symbol()
if sym == nil then comp_error("unexpected end of file") end
local n = parse_number(sym)
if n == nil then comp_error("expected number, got '%s'", sym) end
return n
end
-- Reads symbols until end marker has been reached, processing comments.
-- That is, end markers inside comments are ignored.
function skip_until(end_marker)
while true do
local sym = next_word()
if sym == end_marker then
break
elseif sym == "\\" then
next_symbol_with_delimiter('\n')
elseif sym == "(" then
next_symbol_with_delimiter(')')
end
end
end
-- Returns a string that unique identifies the current parsing location (file and position within it).
function parse_pos()
return input_file .. "@" .. cur_pos
end
-- Checks whether two word names are the same, taking case sensitivity option into account.
function match_word(name1, name2)
if opts.ignore_case then
return string.upper(name1) == string.upper(name2)
else
return name1 == name2
end
end
function read_byte(address)
comp_assert(address < 65536, "address out of range")
return mem[address] or 0
end
function read_short(address, x)
comp_assert(address < 65536 - 1, "address out of range")
return (mem[address] or 0) | ((mem[address + 1] or 0) << 8)
end
function write_byte(address, x)
comp_assert(address < 65536 - 1, "address out of range")
if x < 0 then x = x + 256 end
mem[address] = x & 0xff
end
function write_short(address, x)
comp_assert(address < 65536 - 1, "address out of range")
if x < 0 then x = x + 65536 end
mem[address] = x & 0xff
mem[address + 1] = x >> 8
end
function emit_byte(x)
comp_assert(output_pos < 65536, "out of space")
mem[output_pos] = x
output_pos = output_pos + 1
end
function emit_short(x)
if x < 0 then x = x + 65536 end
emit_byte(x & 0xff)
emit_byte(x >> 8)
end
function emit_string(str)
for i = 1, #str do
emit_byte(str:byte(i))
end
end
function emit_literal(n)
if compile_mode == "mcode" then
if n >= -32768 and n < 65536 then
if n < 0 then n = 65536 + n end
mcode.emit_literal(n)
else
comp_error("literal out of range")
end
else
list_line("lit %d", n)
if n >= 0 and n < 256 and opts.small_literals then
emit_short(PUSH_BYTE)
emit_byte(n)
elseif n >= -32768 and n < 65536 then
if n < 0 then n = 65536 + n end
emit_short(PUSH_WORD)
emit_short(n)
else
comp_error("literal out of range")
end
end
end
-- Erases last N emitted bytes from output dictionary.
function erase(n)
for i = here() - n, here() - 1 do
mem[i] = 0
end
output_pos = output_pos - n
end
-- Returns the address of the next free byte in dictionary in Ace's RAM.
function here()
return output_pos
end
-- Enters interpreter state. Usually called by ;
function interpreter_state()
compile_mode = false
end
-- Returns the current numeric base used by the compiler.
function base()
return mem[0]
end
-- Returns string representation of a number in current numeric base.
function format_number(n)
local base = mem[0]
comp_assert(base >= 2 and base <= 36, "invalid numeric base")
local digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
local result = ""
if n == 0 then return "0" end
local neg = n < 0
if neg then n = math.abs(n) end
while n > 0 do
local d = n % base
result = digits:sub(d + 1, d + 1) .. result
n = n // base
end
if neg then result = "-" ..result end
return result
end
-- Parses number from a string using current numeric base.
function parse_number(str)
local base = mem[0]
comp_assert(base >= 2 and base <= 36, "invalid numeric base")
return tonumber(str, base)
end
-- Fills the word length field of previous word in dictionary.
function update_word_length()
if prev_word_link >= start_address then
-- prev_word_link points to the name length field of the last defined word
-- word length field is always 4 bytes before this
local word_length_addr = prev_word_link - 4
local length = here() - prev_word_link + 4
write_short(word_length_addr, length)
end
end
-- Inserts a header for a new word to output dictionary. The new word has a header but with empty parameter field.
-- Its word length is also zero. The word length field is updated to correct value when the next word is added.
-- This means that the last word will have zero in the word length field. This is how the ROM code works too
-- (and its documented in Jupiter Ace Forth Programming, page 121).
function create_word(code_field, name, flags)
flags = flags or 0
comp_assert(not inside_definition, "; expected")
word_start_addresses[name] = here()
word_flags[name] = flags
word_counts[name] = word_counts[name] or 0
list_header(name)
if not opts.mcode then
update_word_length()
list_comment("word header")
-- write name to dictionary, with terminator bit set for the last character
local name = name
if opts.minimal_word_names and name ~= opts.main_word then name = "@" end
name = string.upper(name)
emit_string(name:sub(1, #name - 1) .. string.char(name:byte(#name) | 128))
emit_short(0) -- placeholder word length
emit_short(prev_word_link)
prev_word_link = here()
emit_byte(#name)
end
-- compilation addresses work differently with interpreted Forth and machine code:
-- interpreter: compilation address points to code field of the word
-- machine code: compilation address points directly to the start of machine code
local compilation_addr = here()
if not opts.mcode then
emit_short(code_field) -- code field
end
-- remember compilation addresses for FIND
compilation_addresses[name] = compilation_addr
-- add word to compile dictionary so that other words can refer to it when compiling
if (flags & F_INVISIBLE) == 0 then
compile_dict[name] = function()
word_counts[name] = word_counts[name] + 1
list_line(name)
emit_short(compilation_addr)
end
end
return name
end
function mark_used(name)
word_counts[name] = word_counts[name] + 1
end
function last_word_name()
return last_word
end
function set_word_flag(name, flag)
word_flags[name] = word_flags[name] | flag
end
-- Erases previously compiled word from dictionary.
-- Returns the contents of the parameter field of the erased word.
function erase_previous_word()
local name = last_word
local start_addr = word_start_addresses[name]
assert(start_addr, "could not determine starting address of previous word")
local compilation_addr = compilation_addresses[name]
assert(compilation_addr, "could not determine compilation address of previous word")
-- fix prev word link
if not opts.mcode then
prev_word_link = read_short(compilation_addr - 3)
end
local code_start = compilation_addr
if not opts.mcode then code_start = code_start + 2 end
-- store old code & listing (skip code field)
local code = {}
local list = {}
local comments = {}
for i = code_start, here() - 1 do
code[#code + 1] = mem[i]
list[i - code_start + 1] = list_lines[i]
comments[i - code_start + 1] = list_comments[i]
end
for i = start_addr, here() - 1 do
mem[i] = 0
list_lines[i] = nil
list_comments[i] = nil
end
word_start_addresses[name] = nil
compilation_addresses[name] = nil
output_pos = start_addr
return code, list, comments, start_addr
end
-- Execute user defined word at compile time.
function execute(pc)
local function fetch_byte()
local x = mem[pc]
pc = pc + 1
return x
end
local function fetch_short()
local x = read_short(pc)
pc = pc + 2
return x
end
local function fetch_signed()
local x = fetch_short()
if x > 32767 then x = x - 65536 end
return x
end
while true do
local instr = fetch_short()
local name = compilation_addr_to_name[instr]
if name then
local func = interpret_dict[name]
if func == nil then
comp_error("could not determine address of %s when executing compiled code", name)
end
func()
elseif instr == FORTH_END then
break
elseif instr == PUSH_BYTE then
push(fetch_byte())
elseif instr == PUSH_WORD then
push(fetch_short())
elseif instr == PUSH_ZERO then
push(0)
elseif instr == CBRANCH then
local offset = fetch_signed() - 1
if pop() == 0 then
pc = pc + offset
end
elseif instr == BRANCH then
pc = pc + fetch_signed() - 1
elseif instr == DO then
local limit, counter = pop2()
r_push(limit)
r_push(counter)
elseif instr == LOOP or instr == PLUS_LOOP then
local offset = fetch_signed() - 1
local counter = r_pop()
local limit = r_pop()
local step = instr == LOOP and 1 or pop()
counter = counter + step
if (step >= 0 and counter < limit) or (step < 0 and counter > limit) then
r_push(limit)
r_push(counter)
pc = pc + offset
end
elseif instr == PRINT then
local len = fetch_short()
for i = 1, len do
io.write(string.char(fetch_byte()))
end
elseif instr == POSTPONE then
local len = fetch_short()
local name = ""
for i = 1, len do
name = name .. string.char(fetch_byte())
end
local func
if compile_mode == "mcode" then
func = mcode_dict[name]
else
func = compile_dict[name]
end
if func == nil then
comp_error("POSTPONE failed -- could not find compile behavior for word '%s'", name)
end
func()
else
comp_error("unknown compilation address $%04x encountered when executing compiled code", instr)
end
end
end
function execute_string(src, filename)
-- initialize parser state
input = src
input_file = filename
cur_pos = 1
cur_line = 1
-- execute input
while true do
local sym = next_word(true)
if sym == nil then break end
--printf("symbol [%s]", sym)
if compile_mode then
-- compile mode
local func
if compile_mode == "mcode" then
func = mcode_dict[sym]
else
func = compile_dict[sym]
end
if func == nil then
-- is it a number?
local n = parse_number(sym)
if n == nil then comp_error("undefined word '%s'", sym) end
emit_literal(n)
else
func()
end
else
-- interpret mode
local func = interpret_dict[sym]
if func == nil then
-- is it a number?
local n = parse_number(sym)
if n == nil then comp_error("undefined word '%s'", sym) end
push(n)
else
func()
end
end
end
end
-- Listings
function list_header(...)
if opts.listing_file then
list_headers[here()] = string.format(...)
end
end
function list_line(...)
if opts.listing_file then
list_lines[here()] = string.format(...)
end
end
function list_comment(...)
if opts.listing_file then
list_comments[here()] = string.format(...)
end
end
function list_comment_append(addr, ...)
if opts.listing_file then
list_comments[addr] = (list_comments[addr] or "") .. string.format(...)
end
end
-- Patches hex literal (jump address) in already emitted listing line.
function list_patch(addr, pattern, replacement)
if opts.listing_file then
local line = list_lines[addr]
assert(line, "invalid listing line")
line = line:gsub(pattern, replacement)
list_lines[addr] = line
end
end
-- Erases all listing lines in given address range.
function list_erase(start_addr, end_addr)
if opts.listing_file then
for i = start_addr, end_addr do
-- not clearing headers on purpose, because erase_literal() at the start of word would erase the header...
--list_headers[i] = nil
list_lines[i] = nil
list_comments[i] = nil
end
end
end
function write_listing(filename)
local file = io.open(filename, "wb")
local addr = start_address
local len = 0
local function align(x)
local spaces = x - len
if spaces > 0 then
file:write(string.rep(" ", spaces))
len = len + spaces
end
end
while addr < here() do
if list_headers[addr] then
if addr > start_address then file:write("\n") end
file:write(list_headers[addr], ":\n")
end
-- find end address of line
local e = here()
for i = addr + 1, here() do
if list_headers[i] or list_lines[i] or list_comments[i] then
e = i
break
end
end
assert(e > addr)
-- add line breaks for long sections of data
e = math.min(e, addr + 16)
file:write(string.format("%04x", addr))
len = 4
-- emit bytes
for i = addr, e - 1 do
file:write(string.format(" %02x", read_byte(i)))
len = len + 3
end
if list_lines[addr] then
align(20)
file:write(" ", list_lines[addr])
len = len + #list_lines[addr] + 1
end
if list_comments[addr] then
align(40)
file:write(" ; ", list_comments[addr])
end
file:write("\n")
addr = e
end
file:close()
end
function patch_forth_jump(instr_addr, jump_to_addr)
write_short(instr_addr + 2, jump_to_addr - instr_addr - 3)
list_patch(instr_addr, "%$%x+", string.format("$%04x", jump_to_addr))
end
interpret_dict = {
create = function()
local name = next_word()
if not eliminate_words[name] then
create_word(DO_PARAM, name, F_NO_INLINE)
inside_definition = true
-- make it possible to refer to the word from machine code
local addr = here()
mcode_dict[name] = function()
mcode.emit_literal(addr, name)
word_counts[name] = word_counts[name] + 1
end
else
skip_until(';')
end
end,
[':'] = function()
local name = next_word()
if not eliminate_words[name] then
local flags = 0
if compile_dict[name] and dont_allow_redefining then flags = F_INVISIBLE end
last_word = create_word(DO_COLON, name, flags)
compile_mode = true
if opts.mcode then
-- load top of stack to DE if this is the machine code entry point from Forth
if name == opts.main_word then
list_line("rst 24")
list_comment("adjust stack for machine code")
emit_byte(0xc7 + 24)
end
compile_mode = "mcode"
if mcode_dict[name] == nil or not dont_allow_redefining then
mcode_dict[name] = function()
mcode.call_mcode(name)
end
end
end
else
skip_until(';')
end
end,
[':m'] = function()
-- compile macro
last_word = create_word(0, next_word(), F_MACRO | F_NO_INLINE | F_NO_ELIMINATE)
compile_mode = true
local addr = next_immediate_word
interpret_dict[last_word] = function() execute(addr) end
compile_dict[last_word] = function() execute(addr) end
mcode_dict[last_word] = function() execute(addr) end
end,
[';'] = function()
-- marks end of CREATE, CODE or BYTES definition
comp_assert(inside_definition, "unexpected ;")
if inside_definition == "bytes" then
-- find start of bytes block
local start
for i = #stack, 1, -1 do
if stack[i] == 'bytes' then
start = i
break
end
end
comp_assert(start, "could not find start of BYTES data (unbalanced compiler stack?)")
for i = start + 1, #stack do
emit_byte(stack[i])
stack[i] = nil
end
stack[start] = nil
end
inside_definition = false
end,
noinline = function()
-- forbid inlining previous word
comp_assert(last_word, "invalid use of NOINLINE")
word_flags[last_word] = word_flags[last_word] | F_NO_INLINE
end,
inline = function()
-- force inline previous word
comp_assert(last_word, "invalid use of INLINE")
comp_assert((word_flags[last_word] & F_HAS_SIDE_EXITS) == 0, "Cannot inline word with side exits")
comp_assert((word_flags[last_word] & F_NO_INLINE) == 0, string.format("Word '%s' cannot be inlined", last_word))