forked from hcchengithub/eforth-x86-64bits
-
Notifications
You must be signed in to change notification settings - Fork 0
/
eforth64.asm
3021 lines (2513 loc) · 99.6 KB
/
eforth64.asm
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
;--------------------------------------------------------------------------------------------------------------
; eforth64.asm
; hcchen5600 2011/07/17 14:01:06 我終於想明白了，eforth64 should be org 0x100000 but MBR should be org 0x7c00 ,
; due to that I'll use NASM without LINKer they must be separaged into two .asm files. That I have two source files,
; "c:\Users\8304018.WKSCN\Documents\My Dropbox\learnings\BIOS DEBUGGER FORTH ENGIN\eforth64\...\MBR.asm"
; "c:\Users\8304018.WKSCN\Documents\My Dropbox\learnings\BIOS DEBUGGER FORTH ENGIN\eforth64\...\eforth64.asm"
; hcchen5600 2011/08/06 10:54:51
; 成功了， eforth64 在 64-bits MBR boot 起來的 Bochs VM 上已經可以執行了。。
; 總結除了 code 改成 64 bits 指令以外，改 64 bits 還有幾個問題。
; 1. 0< 要改，本來的寫法只適用 16 bits。 UM/MOD UM* 裡的 15 要改成 63。
; 2. LAST 以及所有 NFA link 都要加上 COLDD base address. _LINK 初值也不是 0 改用 0-COLDD。
; 16 bits 時是 .com 檔，沒有這個問題。
; 3. 'FIND' 用到一些 cell+ cell- , 16 bits system 這樣用正好是 2+ 2-， 64 bits system 就不對
; 了，當初用 cell+ cell- 想必以為 32bits 64bits 很遙遠。取前兩 bytes 以前用 @ 正好現改成 w@ 才行。
; 4. CALLL CALL, 也要改寫， 64-bits 已經不適用。 c, CCOMMA 有必要。一口氣補足所有的 , c, w, d, ! c, w, d, @ c@ w@ d@
; 5. Word name 改成全部小寫。
; eforth64 修改紀錄：
; 6. r4 適合用來開發 USB debug cable 介面的版本。 r5 為了要在 Bochs 上執行方便，將針對 BS EMIT , CRR EMIT 做些修整。
; 7. digit? 加幾行，令大小寫不分。
; 8. (r6, r15) 寫出了 $eval ( string length -- ... ). (原 eval 用默認的 TIB,#TIB。)
; 9. 新創 callsize+ 隨不同系統 call DOLST 的 size 可以不同。
; 10. r7 r8 到 r9 成功把 assembly code 裡的 console i/o 整個做成空殼，run 起來以後再從 forth source code 裡 install
; console i/o 進來。 r9 一舉改掉了所有已知的問題。500K forth source 整合到 floppy image 裡，改寫 eforth64.f 之後
; 跑一下 build.bat 即可自動產生 floppy.img 在 Bochs, QEMU 都能執行。 以 r9 為 v1.0 版。 hcchen5600 2011/08/13 23:34:01
; 11. R16 把原來 eforth 86ef202.asm 裡有的 dump 相關的 assembly code 拿掉。所有已經移到 high level fcode 的東西都拿掉。
; 12. R19 Changed to STC. R20 supports vocabulary.
;===============================================================
; hcchen5600 100.11.29
; Based on Sir C. H. Ting's below 86eForth, it was DTC. Porting to 64 bits long mode.
; Switch to STC by copying Sir Sam Suan Chen and Sir Yap's weforth (or fsharp) STC words.
; Above modification log FYR.
;===============================================================
; 86eForth 2.02, C. H. Ting, 06/02/99
; Add create, checksum, UPLOAD and DOWNLOAD.
; A sample session looks like:
; c>86ef202
; DOWNLOAD LESSONS.TXT
; WORDS
; ' THEORY 'BOOT !
; UPLOAD TEST.EXE
; BYE
; c>test
;
; 86eForth 2.01, C. H. Ting, 05/24/99
; Merge Zen2.asm with eForth 1.12
;1. Eliminate most of the @EXECUTE thru user variables
;2. Combine name and code dictionary
;3. Eliminate code pointer fields
;4. elimiate catch-throw
;5. eliminate most user variables
;6. extend top memory to FFF0H where the stacks and user area are.
;7. add open, close, read, write; improve BYE
;8 add 1+, 1-, 2/
;
;
; eForth 1.12, C. H. Ting, 03/30/99
; Change READ and LOAD to 'read' and 'load'.
; Make LOAD to read and compile a file. The file
; buffer is from CP+1000 to NP-100.
; To load all the lessons, type:
; LOAD LESSONS.TXT
; and you can test all the examples in this file.
; eForth 1.11, C. H. Ting, 03/25/99
; Change BYE to use function 4CH of INT 21H.
; Add read, write, open, close, READ, and LOAD
; To read a text file into memory:
; HEX 2000 1000 READ TEST.TXT
; READ returns the number of byte actually read.
; To compile the source code in the text file:
; 2000 FCD LOAD
; where FCD is the length returned by READ.
; These additions allow code for other eForth systems
; to be tested on PC first.
; It is part of the Firmware Engineering Workshop.
;
;
; eForth 1.0 by Bill Muench and C. H. Ting, 1990
; Much of the code is derived from the following sources:
; 8086 figForth by Thomas Newman, 1981 and Joe smith, 1983
; aFORTH by John Rible
; bFORTH by Bill Muench
;
; The goal of this implementation is to provide a simple eForth Model
; which can be ported easily to many 8, 16, 24 and 32 bit CPU's.
; The following attributes make it suitable for CPU's of the '90:
;
; small machine dependent kernel and portable high level code
; source code in the MASM format
; direct threaded code
; separated code and name dictionaries
; simple vectored terminal and file interface to host computer
; aligned with the proposed ANS Forth Standard
; easy upgrade path to optimize for specific CPU
;
; You are invited to implement this Model on your favorite CPU and
; contribute it to the eForth Library for public use. You may use
; a portable implementation to advertise more sophisticated and
; optimized version for commercial purposes. However, you are
; expected to implement the Model faithfully. The eForth Working
; Group reserves the right to reject implementation which deviates
; significantly from this Model.
;
; As the ANS Forth Standard is still evolving, this Model will
; change accordingly. Implementations must state clearly the
; version number of the Model being tracked.
;
; Representing the eForth Working Group in the Silicon Valley FIG Chapter.
; Send contributions to:
;
; Dr. C. H. Ting
; 156 14th Avenue
; San Mateo, CA 94402
; (415) 571-7639
;
;===============================================================
;; Debugging switch
MOVEDTOFORTHCODE EQU 1 ; Many words are not used in assembly code, they can be moved to forth code.
FAKESTDIO EQU 1 ; fake keyboard display, they will be provided by high level
; 辛苦寫了一大片 console i/o 的程式，只是為了開發用的鷹架，程式寫好了就要用空殼把他們取代掉。
; 讓最終的 USB debug cable i/o 程式來置換之。用 forth 寫好附在後面讓 $eval install 進來即可。
;; Version control
VER EQU 01 ; major release version
EXT EQU 20 ; minor extension
;; Constants
TRUEE EQU -1 ;true flag
HIDE EQU 020H ; Hide-Reveal is important for code end-code words, eforth 原版沒有，Forth code 裡才出現。 hcchen5600 2011/08/14 22:07:19
COMPO EQU 040H ;lexicon compile only bit
IMEDD EQU 080H ;lexicon immediate bit
MASKK EQU 07F1FH ;lexicon bit mask 7F 是把 name 1st character bit7 mask 掉， 1F 是避開 HIDE COMPO IMEDD 3 bits.
CELLL EQU 8 ;size of a cell 64-bits now so it's 8 bytes hcchen5600 2011/06/13 21:01:06
BASEE EQU 10 ;default radix
VOCSS EQU 8 ;depth of vocabulary stack
BKSPP EQU 8 ;back space
LF EQU 10 ;line feed
CRR EQU 13 ;carriage return
ERR EQU 27 ;error escape
TIC EQU 39 ;tick
RETT EQU 0C3H ; ret opcode
CALLL EQU 0E8H ;CALL opcode , when in 64-bits long mode it's 4 bytes relative target address hcchen5600 2011/08/06 22:03:16
CALLSIZE EQU 5 ;64-bits long mode call instruction total 5 bytes
;; Memory allocation
; hcchen5600 2011/07/17 11:38:33 我一時覺得 TIBB, UPP, SPP, RPP 都可以縮小，因為 BIOS 給的空間不大。轉而一想，不對！那是
; 4k starting code 的問題。Forth 本身想用就用不去管他。
; eforth64 memory map see "Evernote 2011/07/17 11:38 BIOS debug engine developing, eforth memory map"
; In 64 bits version, I use long mode paging tables to create a world with one
; mega memory forth space. The 4k starting code can search the entire main memory
; for a block with all same value then use it and return to that value before ending.
; [ ] hcchen5600 2011/07/17 10:53:56
EM EQU 1FFFF0H ;top of memory. In 16 bits real mode this value is simply a 16 bits offset.
;hcchen5600 2011/07/17 10:56:05 目前 paging 空間定 2M，把 EM 設到整塊空間的尾
;巴處，故為 1FFFF0h.
US EQU 64*CELLL ;user area size in cells
RTS EQU 128*CELLL ;return stack/TIB size
UPP EQU TIBB-RTS ;start of user area (UP0)
RPP EQU UPP-RTS ;start of return stack (RP0)
TIBB EQU EM-RTS ;terminal input buffer (TIB)
SPP EQU UPP-8*CELLL ;start of data stack (SP0)
COLDD EQU 100000h ; hcchen5600 2011/07/17 11:51:47 用來指出 memory map 裡 code 要從哪兒開始。
; 本實做中，從 2M 的 100000h 開始。
BITS 64 ;NASM 64 bits mode switch
;; Initialize assembly variables
%assign _LINK 0-COLDD ;force a null link 因為後面用到 _LINK 都改成 _LINK+COLDD 所以這裡調成 0-COLDD 如此第一個才會是零。
%assign _USER 0 ;first user variable offset
;; Define assembly macros
%macro $POP_RBX 0 ; ( tos- rbx -- tos- ) Original ebx disappeared, ebx becomes new value from [ebp]
mov rbx,[rbp]
lea rbp,[rbp+CELLL] ; 如果嫌用這個太花俏 ....
; add rbp,CELLL ; 簡單加法有何不可？ 會動到 flag, 因此不行！
%endmacro
%macro $PUSH_RBX 0 ; ( rbx -- rbx rbx ) dup ebx value
lea rbp,[rbp-CELLL] ; 如果嫌用這個太花俏 ....
; sub rbp,CELLL ; 簡單減法有何不可？ 會動到 flag, 因此不行！
mov [rbp],rbx
%endmacro
; Compile a code definition header.
%macro $CODE 3 ; %1, %2, %3 = LEX,NAME,LABEL
DQ _LINK+COLDD ; token pointer and link
%assign _LINK $-$$ ; link points to a name string
DB (%1+%3-$-1), %2 ; name string. (%3-$-1)自動算出長度，-1 是 length 自己佔的一個 byte 不算，%1是屬性flags.
%3: ; assembly label
%endmacro
; Compile a colon definition header. For STC it's same as $CODE 乾脆去掉。
%macro $COLON 3 ; %1, %2, %3 = LEX,NAME,LABEL
$CODE %1, %2, %3
%endmacro
; Compile a user variable header.
%macro $USER 3 ; %1, %2, %3 = LEX,NAME,LABEL
$CODE %1, %2, %3
CALL DOUSE ; doUSER
DQ _USER ; offset
%assign _USER _USER+CELLL ; update user area offset
%endmacro
; branch 以及 ?brahcn 各有兩種，各有用場。
; 一種是馬上用在 assembly code 裡的，就是這個，小小的 macro 就可以了。
; 另一種是要 compile 進 dictionary 裡去的，那就當然要寫成 word。
%macro $BRAN 1 ; BRANCH macro
jmp %1
%endmacro
%macro $QBRAN 1 ; ?BRANCH macro, jump when TOS==0
or rbx,rbx
$POP_RBX
jz %1
%endmacro
; 以前 DOS eforth 的 $NEXT 是 code word 的結尾，STC model 的 IP 就是 CPU 的 IP register,
; 因此 $NEXT 單純就是 CPU return. 到了 fsharp $NEXT 變成是 fort..next 的 next. 舊 $NEXT
; 全部先用 ret 換掉。
%macro $NEXT 1 ; for...NEXT MACRO
call DONXT
DQ %1 ; relative adressing 14jun02sam
%endmacro
;; Main entry point
org COLDD
; 把 fcode source backup 到 0x200000 處, COLD 命令要重複使用他。
CLI
CLD
mov rax,0x20008F ; create 2M new page space $200000~$3fffff
mov [0xc008],rax
mov rcx,0x100000/8 ; length 乾脆整個都搬,留有 r17 的手段。
mov rsi,0x100000 ; from
mov rdi,0x200000 ; to
repz movsq
jmp COLD ; ENTRY_POINT need to prepare source code first then call COLD.
; ; r17 COLD will call this subroutine to restore the fcode source.
; ; Here are some tricks, it works when they all work together.
; ; I don't know whether both wbinvd and jmp rbx (instead of ret)
; ; necessary. -- R16 hcchen5600 2011/11/08 18:30:43
; RestoreCode: CLD
; mov rcx,0x8000/8 ; length
; mov rsi,0x200000 ; from
; mov rdi,0x100000 ; to
; repz movsq
; wbinvd
; mov rbx,COLD0
; jmp rbx
; COLD start moves the following to USER variables. 這很重要，等於是在 COLD 時替它們刷成初值。
; 若非如此，有些被改過的值 COLD 也不恢復，馬上就會當機。所有被置換過的 deferred words 皆屬之，重要變數值亦然。
; MUST BE IN SAME ORDER AS USER VARIABLES.
align 16 ; align on 16-byte boundary
UZERO:
DQ BASEE ; 1ff7f0 BASE
DQ 0 ; 1ff7f8 tmp
DQ 0 ; 1ff800 >IN
DQ 0 ; 1ff808 #TIB
DQ TIBB ; 1ff810 TIB
DQ INTER ; 1ff818 'EVAL
DQ 0 ; 1ff820 HLD
DQ 0 ; 1ff828 CONTEXT pointer
DQ CTOP ; 1ff830 CP
DQ LASTN ; 1ff838 LAST last word's NFA
DQ QRX ; 1ff840 '?KEY ?RX
DQ TXSTORE ; 1ff848 'EMIT TX!
DQ 0 ; 1ff850 POSITION screen position
DQ HI ; 1ff858 'BOOT COLD greeting
DQ BBKSLAA ; 1ff860 '\ default is ' \(orig) , default back slash comment
DQ CELLL ; 1ff868 reserve-word-fields RESERVEWORDFIELDS for vocabulary
DQ NAMEQORIG ; 1ff870 'name? TNAMEQ for vocabulary
DQ SNAMEORIG ; 1ff878 '$,n TSNAME for vocabulary
DQ OVERTORIG ; 1ff880 'overt TOVERT for vocabulary
DQ SEMISORIG ; 1ff888 '; TSEMIS for vocabulary
DQ CREATORIG ; 1ff890 'create TCREATE for vocabulary
ULAST: DQ 0,0,0,0
; noop ( -- )
; NOP break point works with Bochsdbg.exe. We need this before console ready.
; This is the first word, whereisit 會用到這個特性。
$CODE IMEDD,'noop',noop
nop ; 放個 nop, debug 設斷點時比單 ret 好認。
ret
; -1 ( -- -1 )
; Minus One
$CODE 0,'-1',MINUS1
$PUSH_RBX ; 要推值進 data stack, 先把 TOS 原先的值推下去
mov rbx,-1 ; 然後把要放進 TOS 的值寫進 RBX
ret
; 0 ( -- 0 )
; Zero
$CODE 0,'0',ZERO
$PUSH_RBX ; 要推值進 data stack, 先把 TOS 原先的值推下去
xor rbx,rbx ; 然後把要放進 TOS 的值寫進 RBX
ret
; 1 ( -- 1 )
; One
$CODE 0,'1',ONE
$PUSH_RBX ; 要推值進 data stack, 先把 TOS 原先的值推下去
mov rbx,1 ; 然後把要放進 TOS 的值寫進 RBX
ret
; 2 ( -- 2 )
; Two
$CODE 0,'2',TWO
$PUSH_RBX ; 要推值進 data stack, 先把 TOS 原先的值推下去
mov rbx,2 ; 然後把要放進 TOS 的值寫進 RBX
ret
; iob@ (port -- byte )
; input a byte from the given i/o port
$CODE 0,'iob@',INPORTB
mov rdx,rbx
xor rax,rax
in al,dx
mov rbx,rax
ret
; iob! ( byte port -- )
; output a byte to the given i/o port
$CODE 0,'iob!',OUTPORTB
mov rdx,rbx
$POP_RBX
mov rax,rbx
$POP_RBX
out dx,al
ret
; ?rx ( -- c T | F )
; fake Return input character and true, or a false if no input.
; This is a fake word used before real word will be ready.
$CODE 0,'?rx',QRX
call ZERO
ret
; tx! ( c -- )
; fake putchar to stdout.
; This is a fake word used before real word will be ready.
$CODE 0,'tx!',TXSTORE
call DROP
ret
; ?key ( -- c T | F )
; Return input character and true, or a false if no input.
$CODE 0,'?key',QKEY
call TQKEY
jmp ATEXE
; ret
; emit ( c -- )
; Send character c to the output device.
$CODE 0,'emit',EMIT
call TEMIT
jmp ATEXE
; ret
;; forth basics
; doLIT ( -- w )
; Push an inline literal.
$CODE COMPO,'dolit',DOLIT
$PUSH_RBX ; 先把原先的 TOS push 進 data stack
pop rax ; pointer to the literal number
mov rbx,[rax] ; get the number to TOS
add rax,CELLL ; adjust the return point
push rax ; 歸還 return point
ret
; [ ] doLIST 作廢 STC 用不著 -- R18 hcchen5600 2011/11/09 15:26:25
; doLIST ( a -- )
; Process colon list.
;
; $CODE 6,'dolist',DOLST
; XCHG rBP,rSP ;exchange the return and data stack pointers
; PUSH rSI ;push on return stack
; XCHG rBP,rSP ;restore the pointers
; POP rSI ;new list address
; ret
;; Hardware reset
; version ( -- EXT VER)
; Get this program's version
$CODE 0,'version',VERSION
$PUSH_RBX ; 要推值進 data stack, 先把 TOS 原先的值推下去
mov rbx,EXT ; 然後把要放進 TOS 的值寫進 RBX
$PUSH_RBX ; 要推值進 data stack, 先把 TOS 原先的值推下去
mov rbx,VER ; 然後把要放進 TOS 的值寫進 RBX
ret
; hi ( -- )
; Display the sign-on message of eForth.
$CODE 0,'hi',HI
call CR
call DOTQP
DB 10,'eForth64 v'
call DOLIT
DQ VER
call DOT
call DOTQP
DB 1,'.'
call DOLIT
DQ EXT
call DOT
call DOTQP
DB 1,' '
jmp CR
; ret
; ENTRY_POINT ( -- )
; The hilevel cold start sequence.
$CODE 0,'cold', COLD
CLI
CLD
MOV rBP,SPP ; initialize SP
MOV rSP,RPP ; initialize RP
COLD1: call DOLIT
DQ UZERO
call DOLIT
DQ UPP
call DOLIT
DQ ULAST-UZERO
call CMOVE ; initialize user area
call PRESE ; initialize data stack and TIB
call OVERT ; necessary for $eval to add any new words
call sourcecode
call DOLIT
DQ 0x100000
call PLUS ; fcode source
call DOLIT
DQ 512*1024 ; length
call SEVAL ; $eval
call TBOOT
call ATEXE ; application boot
call QUIT ; start interpretation
$BRAN COLD ; just in case
; [x] 作廢。 STC 用不著 colon words 的 return 程序了，直接就是 CPU 的 ret 指令。 hcchen5600 2011/11/09 15:42:36
; exit ( -- )
; Terminate a colon definition.
;
; $CODE 0,'exit',EXIT
; MOV rSI,[rBP] ;pop return address
; ADD rBP,CELLL ;adjust RP
; ret
; donext ( -- ) STC hcchen5600 2011/11/11 09:18:38
; Run time code for the single index loop.
; : next ( -- ) \ hilevel model
; r> r> dup if 1 - >r @ >r exit then drop cell+ >r ;
$CODE COMPO,'donext',DONXT ; [ -- ][ -- count ReturnAddress ]
pop rdi ; this function's return address points to the l-value of the for..next loop back point
lea rax , [rdi+CELLL] ; get the address after $NEXT to eax, for end of loop.
sub qword [rsp],1 ; [ -- ][ -- count ] count--
jb nexta ; jb when 0 changed to -1
jmp [rdi] ; repeat the loop
nexta: ;
; pop rcx ; [ -- ][ count -- ] drop the counter
add rsp,CELLL ; rsp+8 == rdrop better than pop.rcx
jmp rax ; continue from next entry by skipping a word
; ?branch ( f -- ) STC hcchen5600 2011/11/11 09:18:38
; Branch if flag is zero.
$CODE COMPO,'?branch',QBRAN
or rbx , rbx ; is TOS true?
$POP_RBX ; TOS consumed
pop rdi ; get target pointer when TOS==NULL
lea rax , [rdi+CELLL] ; get target pointer when TOS!=NULL
jne BRAN1 ;
jmp [rdi] ;
BRAN1: ;
jmp rax ;
; branch ( -- ) STC hcchen5600 2011/11/11 09:18:38
; Branch to an inline address.
$CODE COMPO,'branch',BRAN
pop rdi ; get target pointer
jmp [rdi] ; jmp to target
; execute ( ca -- ) STC hcchen5600 2011/11/11 09:02:27
; Execute the word at ca.
$CODE 0,'execute',EXECU
mov rax,rbx
$POP_RBX
jmp rax ; jump to the code address
; ! ( q a -- ) STC hcchen5600 2011/11/11 09:18:38
; Write data to memory c! , w! , e! , ! store 1 2 4 8 bytes respectively
$CODE 0,'!',STORE
mov rax, [rbp] ; data
mov [rbx], rax ; (address) = data
mov rbx,[rbp+CELLL]
add rbp,CELLL*2 ; adjust RP
ret
; c! ( c b -- ) STC hcchen5600 2011/11/11 09:18:38
; Write data to memory
$CODE 0,'c!',CSTORE
mov rax, [rbp]
mov [rbx],al
mov rbx, [rbp+CELLL]
add rbp,CELLL*2 ; adjust RP
ret
; w! ( w a -- ) STC hcchen5600 2011/11/11 09:18:38
; Write data to memory c! , w! , d! and !
$CODE 0,'w!',WSTORE
mov rax, [rbp]
mov [rbx],ax
mov rbx, [rbp+CELLL]
add rbp,CELLL*2 ; adjust RP
ret
; d! ( d a -- ) STC hcchen5600 2011/11/11 09:18:38
; Write data to memory
$CODE 0,'d!',DSTORE ; DSTOR has been used for 2!
mov rax, [rbp]
mov [rbx],eax
mov rbx, [rbp+CELLL]
add rbp,CELLL*2 ; adjust RP
ret
; @ ( a -- q ) STC hcchen5600 2011/11/11 09:18:38
; Read memory c@ w@ e@ @ : 1 2 4 8 bytes
$CODE 0,'@',ATT
mov rbx,[rbx]
ret
; c@ ( b -- c ) STC hcchen5600 2011/11/11 09:18:38
; Read memory
$CODE 0,'c@',CAT
xor rax,rax
mov al,[rbx]
mov rbx,rax
ret
; w@ ( a -- w ) STC hcchen5600 2011/11/11 09:18:29
; Read memory
$CODE 0,'w@',WAT
xor rax,rax
mov ax,[rbx]
mov rbx,rax
ret
; d@ ( a -- d ) STC hcchen5600 2011/11/11 09:18:19
; Read memory
$CODE 0,'d@',DATT ; DAT has been used for 2@
xor rax,rax
mov eax,[rbx]
mov rbx,rax
ret
; rp@ ( -- a ) STC hcchen5600 2011/11/11 10:12:34
; Push the current RP to the data stack.
$CODE 0,'rp@',RPAT
pop rax
$PUSH_RBX
mov rbx,rsp
JMP rax
; rp! ( a -- )
; Set the return stack pointer.
$CODE COMPO,'rp!',RPSTO
POP rax
MOV rsp,rbx
$POP_RBX
JMP rax
; r> ( -- w )
; Pop the return stack to the data stack.
; $CODE COMPO+2,'r>',RFROM
; PUSH QWORD [rBP]
; ADD rBP,CELLL ;adjust RP
; ret
$CODE 0,'r>',RFROM
$PUSH_RBX
pop rax ; 新奇！ 怎麼想得出來？ 這樣看來， R> 一定是 CALL RFROM 進來的。
pop rbx
jmp rax
; r@ ( -- w )
; Copy top of return stack to the data stack.
; $CODE 2,'r@',RAT
; PUSH QWORD [rBP]
; ret
$CODE 0,'r@',RAT
$PUSH_RBX
mov rbx, [rsp+CELLL] ; 越過自己的 return address 取下一個
ret
; >r ( w -- )
; Push the data stack to the return stack.
$CODE COMPO,'>r',TOR ; STC
pop rax
push rbx
$POP_RBX
jmp rax
; sp@ ( -- a )
; Push the current data stack pointer.
; $CODE 3,'sp@',SPAT
; MOV rBX,rSP ;use BX to index the data stack
; PUSH rBX
; ret
$CODE 0,'sp@',SPAT
$PUSH_RBX
mov rbx,rbp
ret
; sp! ( a -- )
; Set the data stack pointer.
; $CODE 3,'sp!',SPSTO
; POP rSP
; ret
$CODE 0,'sp!',SPSTO
mov rbp,rbx
$POP_RBX
ret ; data stack reset , lodsd is not needed
; drop ( w -- )
; Discard top stack item.
; $CODE 4,'drop',DROP
; ADD rSP,CELLL ;adjust SP
; ret
$CODE 0,'drop',DROP
$POP_RBX
ret
; dup ( w -- w w )
; Duplicate the top stack item.
; $CODE 3,'dup',DUPP
; MOV rBX,rSP ;use BX to index the data stack
; PUSH QWORD [rBX]
; ret
$CODE 0,'dup',DUPP
$PUSH_RBX
ret
; swap ( w1 w2 -- w2 w1 )
; Exchange top two stack items.
; $CODE 4,'swap',SWAP
; POP rBX
; POP rAX
; PUSH rBX
; PUSH rAX
; ret
$CODE 0,'swap',SWAP
mov rax, [rbp]
mov [rbp], rbx
mov rbx, rax
ret
; over ( w1 w2 -- w1 w2 w1 )
; Copy second stack item to top.
; $CODE 4,'over',OVER
; MOV rBX,rSP ;use BX to index the stack
; PUSH QWORD [rBX+CELLL]
; ret
$CODE 0,'over',OVER
$PUSH_RBX
mov rbx, [rbp+CELLL]
ret
; 0< ( n -- t )
; Return true if n is negative.
$CODE 0,'0<',ZLESS
sar rbx,63
ret
; and ( w w -- w )
; Bitwise AND.
; $CODE 3,'and',ANDD
; POP rBX
; POP rAX
; AND rBX,rAX
; PUSH rBX
; ret
$CODE 0,'and',ANDD
and rbx,[rbp]
add rbp,CELLL ; adjust RP
ret
; or ( w w -- w )
; Bitwise inclusive OR.
; $CODE 2,'or',ORR
; POP rBX
; POP rAX
; OR rBX,rAX
; PUSH rBX
; ret
$CODE 0,'or',ORR
or rbx,[rbp]
add rbp,CELLL ; adjust RP
ret
; xor ( w w -- w )
; Bitwise exclusive OR.
; $CODE 3,'xor',XORR
; POP rBX
; POP rAX
; XOR rBX,rAX
; PUSH rBX
; ret
$CODE 0,'xor',XORR
xor rbx,[rbp]
add rbp,CELLL ; adjust RP
ret
; um+ ( u u -- udsum )
; Add two unsigned single numbers and return a double sum.
; $CODE 3,'um+',UPLUS
; XOR rCX,rCX ;CX=0 initial carry flag
; POP rBX
; POP rAX
; ADD rAX,rBX
; RCL rCX,1 ;get carry
; PUSH rAX ;push sum
; PUSH rCX ;push carry
; ret
$CODE 0,'um+',UPLUS
XOR rax,rax ;CX=0 initial carry flag
ADD rbx,[rbp]
RCL rax,1 ;get carry
MOV [rbp],rbx ;push sum
MOV rbx,rax
ret
;; System and user variables
; dovar ( -- a )
; Run time routine for VARIABLE and CREATE.
; $CODE COMPO+5,'dovar',DOVAR
; DQ RFROM,EXIT
$CODE COMPO,'dovar',DOVAR
$PUSH_RBX
pop rbx
ret ; 這個 ret 乍看正常，其實很費解。 我用 sketch pad 3 畫了張圖解 see my Evernote "研究 eforth STC model doVAR 的寫法" hcchen5600 2011/11/11 13:09:20
; up ( -- a )
; Pointer to the user area.
; UP 不能放進 user variables, 因為 access User variables 的 doUSER 就要用到 UP, 任何形式
; 兜成圈子就是不行。還是想讓 up 參加 cold init 而放進去，怎麼搞成間接的或怎的都失敗。只能放棄。
; 這麼一來，理論上 cold 就得替這個 up 設定初值。沒人改就沒事，可以省略。
$CODE 0,'up',UP
call DOVAR
DQ UPP
; sourcecode ( -- a )
; Pointer to the in-binary forth source area.
$CODE 0,'sourcecode',sourcecode
; call DOLIT
; DQ forthcode
; ret
$PUSH_RBX
mov rbx,forthcode
ret
; doUSER ( -- a )
; Run time routine for user variables.
$CODE COMPO,'douser',DOUSE
call RFROM
call ATT
call UP
call ATT
jmp PLUS
; base ( -- a )
; Storage of the radix base for numeric I/O.
$USER 0,'base',BASE
; tmp ( -- a )
; A temporary storage location used in parse and find.
$USER COMPO,'tmp',TEMP
; >in ( -- a )
; Hold the character pointer while parsing input stream.
$USER 0,'>in',INN
; #tib ( -- a )
; Hold the current count in and address of the terminal input buffer.
$USER 0,'#tib',NTIB
; <tib> ( -- a )
; Hold the base address of the terminal input buffer
; TIB 的定義是取得 r-value 故由他處另外定義，這裡單保留位置而不用 $USER 來定義出 TIB。
%assign _USER _USER+CELLL
; 'eval ( -- a )
; Execution vector of EVAL.
$USER 0,"'eval",TEVAL
; hld ( -- a )
; Hold a pointer in building a numeric output string.
$USER 0,'hld',HLD
; context ( -- a )
; A area to specify vocabulary search order.
$USER 0,'context',CNTXT
; cp ( -- a )
; Point to the top of the code dictionary.
$USER 0,'cp',CP
; last ( -- a )
; Point to the last name in the name dictionary.
$USER 0,'last',LAST
; '?key ( -- a )
; Console input device. Normally is keyboard.
$USER 0,"'?key",TQKEY
; 'emit ( -- a )
; Console output device. Normally is text display.
$USER 0,"'emit",TEMIT
; position ( -- a )
; 80*25 screen linear position
$USER 0,'position',POSITION
; 'boot ( -- a )
; The application startup vector.
$USER 0,"'boot",TBOOT
; '\ ( -- a )
; Comment \ can be normal \ or // for console or source file respectively.
$USER 0,"'\",TBKSLASH
; reserve-word-fields ( -- addr )
; 要在當 'colon :' 以及 'create' 創造新 word 時, 在 [link]'string' 之前保留 LFA 或多塞幾個
; field 變成 [VFA][EFA][LFA]'string' 這個動作用 word 來保留是最好的，不這麼做真的不漂亮。
; 這麼做也不算有問題，其實可能是最好的辦法。我對此的改良是 word 裡面保留 cell 數改做成活的
; 用這個變數解決。若想改整個 kernel 則光從這裡下手不夠，也得要改 $CODE macro，我不那麼做。
$USER 0,"reserve-word-fields", RESERVEWORDFIELDS
; 'name? ( -- a )
; These deferred words will need new version after supporting vocabulary
$USER 0,"'name?", TNAMEQ
; '$,n ( -- a )
; These deferred words will need new version after supporting vocabulary
$USER 0,"'$,n", TSNAME
; 'overt ( -- a )
; These deferred words will need new version after supporting vocabulary
$USER 0,"'overt", TOVERT
; '; ( -- a )
; These deferred words will need new version after supporting vocabulary
$USER 0,"';", TSEMIS
; 'create ( -- a )
; These deferred words will need new version after supporting vocabulary
$USER 0,"'create",TCREATE
;; Common functions
; ?dup ( w -- w w | 0 )
; Dup tos if its is not zero.
$CODE 0,'?dup',QDUP
call DUPP
$QBRAN QDUP1
call DUPP
QDUP1: ret
; rot ( w1 w2 w3 -- w2 w3 w1 )
; Rot 3rd item to top.
$CODE 0,'rot',ROT
call TOR
call SWAP
call RFROM
jmp SWAP
; ret
; 2drop ( w w -- )
; Discard two items on stack.
$CODE 0,'2drop',DDROP
call DROP
jmp DROP
; ret
; 2dup ( w1 w2 -- w1 w2 w1 w2 )
; Duplicate top two items.