-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy path4orth.porth
1008 lines (938 loc) · 34.9 KB
/
4orth.porth
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
// The porth to wasm compiler implemented over a modified Porth implementation.
include "modules/4std.porth"
include "modules/porth-4ork.porth"
proc include-paths-add-env int ptr in
getenv-check if
cstr-to-str append-std
include-paths-add
else drop end
end
proc generate-wasm-op-comment ptr ptr in
let op bfd in
op Op.type ptr+ @int
op Op.operand ptr+ @int
op Op.token ptr+
let type operand token in
" ;; " bfd bputs
type OP_INTRINSIC = if
token Token.text ptr+ @Str bfd bputs
else
type op-type-as-str bfd bputs
" " bfd bputs
operand bfd bputu
end
"\n" bfd bputs
end
end
end
const sizeof(wasm-mem) 65536 end // 0x10000
const sizeof(porth-stack) 64 64 * end // 0x1000
const wasm-data-stack sizeof(wasm-mem) sizeof(porth-stack) - end
memory wasm-mem-start sizeof(int) end
memory wasm-global-mem sizeof(int) end
memory wasm-return-stack sizeof(int) end
memory skip-inline sizeof(bool) end
memory proc-layers sizeof(int) OPS_CAP * end
memory proc-index sizeof(int) end
inline proc proc-get int -- int in sizeof(int) * proc-layers +ptr @int end
inline proc proc-set int in proc-index @int sizeof(int) * proc-layers +ptr !int end
inline proc proc-iota int -- int in proc-set proc-index @int proc-index inc64 end
memory ifstar-layers sizeof(int) sizeof(int) * 8 * end
memory ifstar-current sizeof(int) end
inline proc @ifstar-count -- int in ifstar-layers ifstar-current @int sizeof(int) * ptr+ @int end
inline proc !ifstar-count int in ifstar-layers ifstar-current @int sizeof(int) * ptr+ !int end
inline proc ifstar-count.inc in @ifstar-count 1 + !ifstar-count end
inline proc ifstar-count.dec in @ifstar-count 1 - !ifstar-count end
proc generate-op-wat
int // ip
ptr // bfd
in
let ip bfd in
ip sizeof(Op) * ops +ptr
let op in
op Op.type ptr+ @int
op Op.operand ptr+ @int
let type operand in
assert "Exhaustive handling of Op types in generate-op-wat" COUNT_OPS 27 = end
skip-inline @bool if
else type OP_RET = if*
operand 0 > if
" i32.const " bfd bputs operand bfd bputu
" call $free_local" bfd bputs
end
")" bfd bputs
else type OP_PUSH_INT = if*
memory int-value sizeof(int) end operand int-value !int
" i32.const " bfd bputs int-value @32 bfd bputu
" call $push" bfd bputs
else type OP_PUSH_BOOL = if*
" i32.const " bfd bputs operand bfd bputu
" call $push" bfd bputs
else type OP_PUSH_PTR = if*
" i32.const " bfd bputs operand bfd bputu
" call $push" bfd bputs
else type OP_PUSH_ADDR = if*
" i32.const " bfd bputs
proc-index @int while dup 0 >= over proc-get operand != land do
1 -
end bfd bputu
" call $push" bfd bputs
else type OP_CALL_LIKE = if*
" call $pop" bfd bputs
" call_indirect (type $CallLike)" bfd bputs
else type OP_BIND_LET = if*
0 while dup operand < do
" call $bind" bfd bputs
1 +
end drop
else type OP_BIND_PEEK = if*
0 while dup operand < do
" call $bind" bfd bputs
1 +
end drop
0 while dup operand < do
"\n i32.const " bfd bputs dup 1 + 4 * bfd bputu
" call $push_bind" bfd bputs
1 +
end drop
else type OP_UNBIND = if*
" i32.const " bfd bputs operand 4 * bfd bputu
" call $free_local" bfd bputs
else type OP_PUSH_BIND = if*
" i32.const " bfd bputs operand 1 + 4 * bfd bputu
" call $push_bind" bfd bputs
else type OP_PUSH_LOCAL_MEM = if*
" global.get $RETURN_STACK_TOP" bfd bputs
" i32.const " bfd bputs operand 8 / 1 + 4 * bfd bputu
" i32.sub call $push" bfd bputs
else type OP_PUSH_GLOBAL_MEM = if*
" i32.const " bfd bputs operand wasm-global-mem @int + bfd bputu
" call $push" bfd bputs
else type OP_PUSH_STR = if*
" i32.const " bfd bputs op Op.token ptr+ Token.value ptr+ @Str drop bfd bputu
" call $push" bfd bputs
" global.get $str" bfd bputs operand bfd bputu
" call $push" bfd bputs
else type OP_PUSH_CSTR = if*
" global.get $str" bfd bputs operand bfd bputu
" call $push" bfd bputs
else type OP_INJECTED = if*
else type OP_INJECT_CODE = if*
operand sizeof(Str) * injections +ptr @Str bfd bputs
else type OP_IF = if*
ifstar-current inc64
" call $pop" bfd bputs
" if" bfd bputs
else type OP_IFSTAR = if*
ifstar-count.inc
" call $pop" bfd bputs
" if" bfd bputs
else type OP_ELSE = if*
" else" bfd bputs
else type OP_END_WHILE = if*
" br $while" bfd bputs operand 1 + bfd bputu
" end" bfd bputs
" end" bfd bputs
else type OP_END_IF = if*
while @ifstar-count 0 > do
" end" bfd bputs
ifstar-count.dec
end ifstar-current dec64
" end" bfd bputs
else type OP_WHILE = if*
" loop $while" bfd bputs operand bfd bputu
else type OP_DO = if*
" call $pop" bfd bputs
" if" bfd bputs
else type OP_PREP_PROC = if*
op Op.token ptr+ Token.text ptr+ @Str proc-lookup-by-name
let prok in
prok NULL ptr= if
here eputs ": Assertion Failed: couldn't find proc name by token text" eputs
1 exit
end
prok Proc.inlinable ptr+ @bool
prok Proc.imported ptr+ @int 0 != lor
if
true skip-inline !bool
else
false skip-inline !bool
"\n(elem (i32.const " bfd bputs ip proc-iota bfd bputu
") $f" bfd bputs ip bfd bputu
")\n(func $f" bfd bputs ip bfd bputu
" ;; proc " bfd bputs prok Proc.name ptr+ @Str bfd bputs
operand 0 > if
"\n i32.const " bfd bputs operand bfd bputu
" call $aloc_local" bfd bputs
end
end
end
else type OP_CALL = if*
op Op.token ptr+ Token.text ptr+ @Str proc-lookup-by-name
let prok in
prok NULL ptr= if
here eputs ": Assertion Failed: couldn't find proc name by token text" eputs
1 exit
end
prok Proc.imported ptr+ @int 0 != if
prok Proc.ins ptr+
TypeStack.top ptr+ @ptr
dup NULL ptr!= if
while dup NULL ptr!= do
" call $pop" bfd bputs
TypeFrame.prev ptr+ @ptr
end drop
else drop end
end
" call $f" bfd bputs
prok Proc.name ptr+ @Str "rnd" streq if
"rnd" bfd bputs
else
operand bfd bputu
end
prok Proc.imported ptr+ @int 0 != if
prok Proc.outs ptr+
TypeStack.top ptr+ @ptr
dup NULL ptr!= if
while dup NULL ptr!= do
" call $push" bfd bputs
TypeFrame.prev ptr+ @ptr
end drop
else drop end
end
end
else type OP_INLINED = if*
else type OP_INTRINSIC = if*
assert "Exhaustive handling of Intrinsics in generate-op-wat"
COUNT_INTRINSICS 46 =
end
operand INTRINSIC_PLUS = if
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.add" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_MINUS = if*
" call $swap" bfd bputs
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.sub" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_MUL = if*
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.mul" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_DIVMOD = if*
" call $divmod" bfd bputs
else operand INTRINSIC_IDIVMOD = if*
" call $divmod" bfd bputs
else operand INTRINSIC_MAX = if*
" call $pop" bfd bputs
" f32.convert_i32_s" bfd bputs
" call $pop" bfd bputs
" f32.convert_i32_s" bfd bputs
" f32.max " bfd bputs
" i32.trunc_f32_s" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_SHR = if*
" call $swap" bfd bputs
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.shr_s" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_SHL = if*
" call $swap" bfd bputs
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.shl" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_OR = if*
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.or" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_AND = if*
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.and" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_NOT = if*
" call $pop" bfd bputs
" i32.const -1" bfd bputs
" i32.xor" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_PRINT = if*
" call $pop" bfd bputs
" call $f" bfd bputs
"trace" proc-lookup-by-name
Proc.addr ptr+ @int bfd bputu
else operand INTRINSIC_EQ = if*
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.eq" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_GT = if*
" call $swap" bfd bputs
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.gt_s" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_LT = if*
" call $swap" bfd bputs
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.lt_s" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_GE = if*
" call $swap" bfd bputs
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.ge_s" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_LE = if*
" call $swap" bfd bputs
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.le_s" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_NE = if*
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.ne" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_DUP = if*
" call $dup" bfd bputs
else operand INTRINSIC_SWAP = if*
" call $swap" bfd bputs
else operand INTRINSIC_DROP = if*
" call $drop" bfd bputs
else operand INTRINSIC_OVER = if*
" call $over" bfd bputs
else operand INTRINSIC_ROT = if*
" call $rot" bfd bputs
else operand INTRINSIC_LOAD8 = if*
" call $pop" bfd bputs
" i32.load8_u" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_STORE8 = if*
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.store8" bfd bputs
else operand INTRINSIC_LOAD16 = if*
" call $pop" bfd bputs
" i32.load16_u" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_STORE16 = if*
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.store16" bfd bputs
else operand INTRINSIC_LOAD32 = if*
" call $pop" bfd bputs
" i32.load" bfd bputs
" call $push" bfd bputs
else operand INTRINSIC_STORE32 = if*
" call $pop" bfd bputs
" call $pop" bfd bputs
" i32.store" bfd bputs
else operand INTRINSIC_LOAD64 = if*
here eputs ": 4orth does not support u64.\n" eputs
1 exit
else operand INTRINSIC_STORE64 = if*
here eputs ": 4orth does not support u64.\n" eputs
1 exit
else operand INTRINSIC_ARGC = if*
else operand INTRINSIC_ARGV = if*
else operand INTRINSIC_ENVP = if*
else operand INTRINSIC_CAST_PTR = if*
else operand INTRINSIC_CAST_INT = if*
else operand INTRINSIC_CAST_BOOL = if*
else operand INTRINSIC_CAST_ADDR = if*
else operand INTRINSIC_SYSCALL0 = if*
else operand INTRINSIC_SYSCALL1 = if*
else operand INTRINSIC_SYSCALL2 = if*
else operand INTRINSIC_SYSCALL3 = if*
else operand INTRINSIC_SYSCALL4 = if*
else operand INTRINSIC_SYSCALL5 = if*
else operand INTRINSIC_SYSCALL6 = if*
else operand INTRINSIC_??? = if*
else
here eputs ": unreachable. Invalid intrinsic.\n" eputs
1 exit
end
else
here eputs ": unreachable. Invalid op.\n" eputs
1 exit
end
skip-inline @bool if
type OP_RET = if
false skip-inline !bool
end
else
op bfd generate-wasm-op-comment
// "\n" bfd bputs
end
end
end
end
end
memory raw-wasm sizeof(bool) end
proc generate-wasm-imports
int // ip
ptr // bfd
in
over sizeof(Op) * ops +ptr Op.type ptr+ @int OP_PREP_PROC = if
let ip bfd in
ip sizeof(Op) * ops +ptr Op.token ptr+ Token.text ptr+ dup @Str
proc-lookup-by-name
let name prok in
prok NULL ptr= if
here eputs ": Assertion Failed: couldn't find proc name by token text" eputs
1 exit
end
prok Proc.imported ptr+ @int 0 != if
"(import \"" bfd bputs
prok Proc.imported ptr+ @int 1 - sizeof(Str) *
wasm-modules +ptr @Str bfd bputs
"\" \"" bfd bputs
name @Str bfd bputs
"\" (func $f" bfd bputs ip bfd bputu
prok Proc.ins ptr+
TypeStack.top ptr+ @ptr
dup NULL ptr!= if
" (param" bfd bputs
while dup NULL ptr!= do
" i32" bfd bputs
TypeFrame.prev ptr+ @ptr
end drop
")" bfd bputs
else drop end
prok Proc.outs ptr+
TypeStack.top ptr+ @ptr
dup NULL ptr!= if
" (result" bfd bputs
while dup NULL ptr!= do
" i32" bfd bputs
TypeFrame.prev ptr+ @ptr
end drop
")" bfd bputs
else drop end
"))\n" bfd bputs
end
end
end
else drop drop end
end
proc generate-wasm-exports
int // ip
ptr // bfd
in
let ip bfd in
ip sizeof(export) * exports +ptr dup @Str
proc-lookup-by-name swap sizeof(Str) ptr+
let prok eksport in
prok NULL ptr!= if
"(export \"" bfd bputs
eksport @Str bfd bputs
"\"" bfd bputs
" (func $f" bfd bputs
prok Proc.addr ptr+ @int bfd bputu
"))\n" bfd bputs
end
end
end
end
proc inc-by-char-count ptr ptr in
memory str sizeof(Str) end
@Str str !Str
memory count sizeof(ptr) end
count !ptr
while
while
str @Str.count 0 > "\\"
str @Str str-starts-with
lnot land
do
count @ptr inc64
str str-chop-one-left
end
str @Str.count 3 >= "\\"
str @Str str-starts-with
land
do
str 3
str-chop-left-by
count @ptr inc64
end
end
proc generate-wat
ptr // file-path
in
memory char-counter sizeof(int) end
0 char-counter !int
memory bfd sizeof(Bfd) end
sizeof(Bfd) 0 bfd memset drop
let file-path in
silent @bool lnot if
"[INFO] Generating " puts
file-path cstr-to-str puts
"\n" puts
end
420 // mode
O_CREAT O_WRONLY or O_TRUNC or // flags
file-path // pathname
AT_FDCWD
openat
BFD_CAP tmp-alloc
let fd buff in
fd bfd Bfd.fd ptr+ !int
buff bfd Bfd.buff ptr+ !ptr
fd 0 < if
"[ERROR] could not open file\n" eputs
1 exit
end
"(type $CallLike (func))\n\n" bfd bputs
0 while dup ops-count @64 < do
dup bfd generate-wasm-imports
1 +
end drop
raw-wasm @bool if
"(memory 1)\n" bfd bputs
"(export \"memory\" (memory 0))\n" bfd bputs
else
6560 wasm-mem-start !int // 0x19a0
"(import \"" bfd bputs
wasm-modules @Str bfd bputs
"\" \"memory\" (memory 1))\n" bfd bputs
end
0 while dup strlits-count @64 < do
let i in
i sizeof(Str) * strlits +ptr
let str in
str ?str-empty lnot if
"\n(global $str" bfd bputs i bfd bputu
" i32 (i32.const " bfd bputs
char-counter @int wasm-mem-start @int + bfd bputu
"))" bfd bputs
char-counter str
inc-by-char-count
end
end
i 1 +
end
end drop
wasm-mem-start @int
char-counter @int
8 / 1 + 8 * + dup
wasm-global-mem !int
global-memory-capacity @int +
wasm-return-stack !int
wasm-return-stack @int wasm-data-stack > if
"[ERROR] Global memory size exceeds the limits\n" eputs
"[INFO] use ./4orth summary to view more details\n" puts
1 exit
end
"\n(global $RETURN_STACK_TOP (mut i32) (i32.const " bfd bputs wasm-return-stack @int bfd bputu "))" bfd bputs
"\n(global $DATA_STACK_TOP (mut i32) (i32.const " bfd bputs wasm-data-stack bfd bputu "))" bfd bputs
"\n(global $DATA_STACK i32 (i32.const " bfd bputs wasm-data-stack bfd bputu "))\n\n" bfd bputs
"(func $dup (local i32)\n" bfd bputs
" call $pop local.tee 0\n" bfd bputs
" call $push local.get 0\n" bfd bputs
" call $push)\n\n" bfd bputs
"(func $swap (local i32)\n" bfd bputs
" call $pop\n" bfd bputs
" call $pop local.set 0\n" bfd bputs
" call $push local.get 0\n" bfd bputs
" call $push)\n\n" bfd bputs
"(func $over (local i32 i32)\n" bfd bputs
" call $pop local.set 1\n" bfd bputs
" call $pop local.tee 0\n" bfd bputs
" call $push local.get 1\n" bfd bputs
" call $push local.get 0\n" bfd bputs
" call $push)\n\n" bfd bputs
"(func $drop call $pop drop)\n\n" bfd bputs
"(func $rot (local i32)\n" bfd bputs
" call $pop\n" bfd bputs
" call $pop\n" bfd bputs
" call $pop local.set 0\n" bfd bputs
" call $push\n" bfd bputs
" call $push local.get 0\n" bfd bputs
" call $push)\n\n" bfd bputs
"(func $divmod (local i32 i32)\n" bfd bputs
" call $pop local.set 0\n" bfd bputs
" call $pop local.tee 1\n" bfd bputs
" local.get 0 i32.rem_s\n" bfd bputs
" local.get 1 local.get 0\n" bfd bputs
" i32.div_s call $push\n" bfd bputs
" call $push)\n\n" bfd bputs
"(func $push (param i32)\n" bfd bputs
" global.get $DATA_STACK_TOP\n" bfd bputs
" local.get 0 i32.store\n" bfd bputs
" global.get $DATA_STACK_TOP\n" bfd bputs
" i32.const 4 i32.add \n" bfd bputs
" global.set $DATA_STACK_TOP)\n\n" bfd bputs
"(func $pop (result i32)\n" bfd bputs
" global.get $DATA_STACK_TOP\n" bfd bputs
" i32.const 4 i32.sub\n" bfd bputs
" global.set $DATA_STACK_TOP\n" bfd bputs
" global.get $DATA_STACK_TOP\n" bfd bputs
" i32.load)\n\n" bfd bputs
"(func $aloc_local (param i32)\n" bfd bputs
" (local i32)\n" bfd bputs
" global.get $RETURN_STACK_TOP\n" bfd bputs
" local.get 0 i32.add local.tee 1\n" bfd bputs
" global.get $DATA_STACK i32.ge_u\n" bfd bputs
" if unreachable end local.get 1\n" bfd bputs
" global.set $RETURN_STACK_TOP)\n\n" bfd bputs
"(func $free_local (param i32)\n" bfd bputs
" global.get $RETURN_STACK_TOP\n" bfd bputs
" local.get 0 i32.sub\n" bfd bputs
" global.set $RETURN_STACK_TOP\n" bfd bputs
" global.get $RETURN_STACK_TOP\n" bfd bputs
" i32.const 0 local.get 0 \n" bfd bputs
" memory.fill)\n\n" bfd bputs
"(func $bind\n" bfd bputs
" global.get $RETURN_STACK_TOP \n" bfd bputs
" call $pop i32.store\n" bfd bputs
" i32.const 4 call $aloc_local)\n\n" bfd bputs
"(func $push_bind (param i32)\n" bfd bputs
" global.get $RETURN_STACK_TOP\n" bfd bputs
" local.get 0 i32.sub i32.load \n" bfd bputs
" call $push)\n" bfd bputs
"main" proc-lookup-by-name
let main-proc in
main-proc NULL ptr= if
here eputs ": Assertion Failed: type checking phase did not check the existence of `main` procedure\n" eputs
1 exit
end
end
0 ifstar-current !int
0 while dup ops-count @64 < do
dup bfd generate-op-wat
1 +
end drop
"\n(table " bfd bputs
proc-index @64 bfd bputu
" funcref)\n" bfd bputs
0 while dup exports-count @64 < do
dup bfd generate-wasm-exports
1 +
end drop
strlits-count @64 0 > if
"(data (i32.const " bfd bputs wasm-mem-start @int bfd bputu ")\n" bfd bputs
0 while dup strlits-count @64 < do
let i in
i sizeof(Str) * strlits +ptr
let str in
str ?str-empty lnot if
" " bfd bputs
str @Str bfd bputwatstr
end
end
"\n" bfd bputs
i 1 +
end
end drop
")" bfd bputs
end
bfd bflush
fd close drop
buff tmp-rewind
end
end
end
proc wasm-usage
ptr // program name
int // fd
in
let name fd in
"Usage: " eputs name cstr-to-str puts " [OPTIONS] <SUBCOMMAND>\n" fd fputs
" OPTIONS:\n" fd fputs
" -porth Use the original porth compiler and CLI instead of 4orth.\n" fd fputs
" -unsafe Disable type checking.\n" fd fputs
" -I <path> Add <path> to the include paths list.\n" fd fputs
" SUBCOMMANDS:\n" fd fputs
" com [OPTIONS] <file> Compile the program\n" fd fputs
" OPTIONS:\n" fd fputs
// TODO: implement -o flag for com subcommand
" -r Run the program after successful compilation\n" fd fputs
" -b Bundles the program to a linux executable. (If with -r, executes the bundle)\n" fd fputs
" -opt Optimize the program with wasm-opt\n" fd fputs
" -wat Transforms the stripped program back from the final `.wasm` to `.wat` \n" fd fputs
" -wasm Target WASM instead of Wasm4 (doesn't support -b or -r)\n" fd fputs
" -s Silent mode. Don't print any info about compilation phases\n" fd fputs
" -o <file> File to write the result to \n" fd fputs
// " dump <file> Dump the ops of the program\n" fd fputs
// " lex <file> Produce lexical analysis of the file\n" fd fputs
// " summary <file> Print the summary of the program\n" fd fputs
" help Print this help to stdout and exit with 0 code\n" fd fputs
end
end
proc wasm-main in
memory output-file-path-cstr sizeof(ptr) end
NULL output-file-path-cstr !ptr
memory optimize sizeof(bool) end
false optimize !bool
memory wasm2wat sizeof(bool) end
false wasm2wat !bool
memory bundle sizeof(bool) end
false bundle !bool
memory output sizeof(bool) end
false output !bool
args @@ptr "com"c cstreq if
while
args sizeof(ptr) inc64-by
args @@ptr NULL ptr= if
false // break
else args @@ptr "-r"c cstreq if*
true run !bool
true // continue
else args @@ptr "-s"c cstreq if*
true silent !bool
true // continue
else args @@ptr "-b"c cstreq if*
true bundle !bool
true // continue
else args @@ptr "-opt"c cstreq if*
true optimize !bool
true // continue
else args @@ptr "-wat"c cstreq if*
true wasm2wat !bool
true // continue
else args @@ptr "-wasm"c cstreq if*
true raw-wasm !bool
true // continue
else args @@ptr "-o"c cstreq if*
true output !bool
args sizeof(ptr) inc64-by
args @@ptr NULL ptr= if
false
else
args @@ptr output-file-path-cstr !ptr
true // continue
end
else
args @@ptr input-file-path-cstr !ptr
args sizeof(ptr) inc64-by
false // break
end
do end
input-file-path-cstr @ptr NULL ptr= if
program @ptr stderr wasm-usage
"[ERROR] no input file is provided for the compilation.\n" eputs
1 exit
end
raw-wasm @bool run @bool bundle @bool lor land if
"ERROR: Wasm compile option can't be used with bundle or run\n" eputs
1 exit
end
input-file-path-cstr @ptr cstr-to-str remove-ext base-file-path !Str
input-file-path-cstr @ptr compile-program-into-ops
unsafe @bool lnot if type-check-program end
output @bool if
output-file-path-cstr @ptr cstr-to-str remove-ext base-file-path !Str
end
timeit/from-here
fpb-end
base-file-path @Str fpb-append drop
".wat" fpb-append drop
1 fpb-alloc drop
dup generate-wat
fpb-rewind
"[INFO] Generation" silent @bool timeit/to-here
timeit/from-here
cmd-dev-null-stdout @bool
silent @bool cmd-dev-null-stdout !bool
fpb-end
tmp-end
"wat2wasm"c tmp-append-ptr
"--enable-bulk-memory"c tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
".wat" fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
"-o"c tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
".wasm" fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
NULL tmp-append-ptr
silent @bool lnot cmd-echoed
fpb-rewind
cmd-dev-null-stdout !bool
"[INFO] wat2wasm" silent @bool timeit/to-here
optimize @bool if
fpb-end
tmp-end
"wasm-opt"c tmp-append-ptr
"-Oz"c tmp-append-ptr
"--enable-bulk-memory"c tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
".wasm" fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
"-o"c tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
".wasm" fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
NULL tmp-append-ptr
silent @bool lnot cmd-echoed
fpb-rewind
end
wasm2wat @bool if
fpb-end
tmp-end
"wasm2wat"c tmp-append-ptr
"--enable-bulk-memory"c tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
".wasm" fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
"-o"c tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
".wat" fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
NULL tmp-append-ptr
silent @bool lnot cmd-echoed
fpb-rewind
end
bundle @bool if
fpb-end
tmp-end
"w4"c tmp-append-ptr
"bundle"c tmp-append-ptr
"--title"c tmp-append-ptr
"4orth Game"c tmp-append-ptr
"--linux"c tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
".wasm" fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
NULL tmp-append-ptr
silent @bool lnot cmd-echoed
fpb-rewind
run @bool if
fpb-end
tmp-end
fpb-end
base-file-path @Str fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
NULL tmp-append-ptr
silent @bool lnot cmd-echoed
fpb-rewind
end
else run @bool if*
fpb-end
tmp-end
"w4"c tmp-append-ptr
"run"c tmp-append-ptr
fpb-end
base-file-path @Str fpb-append drop
".wasm" fpb-append drop
1 fpb-alloc drop
tmp-append-ptr
NULL tmp-append-ptr
silent @bool lnot cmd-echoed
fpb-rewind
end
else args @@ptr "help"c cstreq if*
program @ptr stdout wasm-usage
0 exit
else args @@ptr "dump"c cstreq if*
args sizeof(ptr) inc64-by
args @@ptr NULL ptr= if
program @ptr stderr wasm-usage
"ERROR: no input file is provided for the `dump` subcommand\n" eputs
1 exit
end
args @@ptr compile-program-into-ops
unsafe @bool lnot if type-check-program end
dump-ops
else args @@ptr "lex"c cstreq if*
args sizeof(ptr) inc64-by
args @@ptr NULL ptr= if
program @ptr stderr wasm-usage
"ERROR: no input file is provided for the `lex` subcommand\n" eputs
1 exit
end
args @@ptr lex-file
else args @@ptr "summary"c cstreq if*
args sizeof(ptr) inc64-by
args @@ptr NULL ptr= if
program @ptr stderr wasm-usage
"ERROR: no input file is provided for the `dump` subcommand\n" eputs
1 exit
end
args @@ptr compile-program-into-ops
unsafe @bool lnot if type-check-program end
summary
else
program @ptr stderr wasm-usage
"ERROR: unknown subcommand `" eputs args @@ptr cstr-to-str eputs "`\n" eputs
1 exit
end
end
proc main in
// Default include paths
"." include-paths-add
"./std" include-paths-add
"./porth/std" include-paths-add
"_4ORTH" include-paths-add-env
"PORTH" include-paths-add-env
NULL input-file-path-cstr !ptr
0 NULL base-file-path !Str
false run !bool
argv args !ptr
args @@ptr program !ptr
false unsafe !bool
memory porth-mode sizeof(bool) end
false porth-mode !bool
while
args sizeof(ptr) inc64-by
args @@ptr NULL ptr= if
false // break
else args @@ptr "-unsafe"c cstreq if*
true unsafe !bool
true // continue
else args @@ptr "-I"c cstreq if*
args sizeof(ptr) inc64-by
args @@ptr
dup ?null if
"ERROR: no argument is provided for -I flag\n" eputs
1 exit
end
dup cstr-to-str include-paths-add
drop
true // continue
else args @@ptr "-porth"c cstreq if*
true porth-mode !bool
true // continue
else
false // break
end
do end
args @@ptr NULL ptr= if
program @ptr stderr
porth-mode @bool if usage else wasm-usage end
"ERROR: subcommand is not provided\n" eputs
1 exit