;# ============= ELF FILE HEADER
;# ============= ELF PROGRAM HEADER
format elf64 executable

;# ============= FORTH INTERPRETER
;# MACHINE CODE ########## INTENTION ############ 78 INSTRUCTION ####### OPCODE ######## ModR/M #### SIB ######
entry $ ;0x0000000000400078
	mov esi, bi.subs
	mov edi, Dictionary
;######################### binary interpreter >>> 82 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
bi:
	call .bi
	jmp bi
;# # # # # # # # # # # # # (bi)                   89
.bi:
GRAPHIC	equ 60h
BI_EXEC	equ 80h
COMMAND equ 99h
	lodsb
	cmp al, COMMAND
	je @f
	stosb
	ret
@@:
	mov edx, Latest
	lodsb
	test al, GRAPHIC
	jz Head
	mov rbx, [rdx]
;# _find1:               #                        9D
.find1:
	push rax
	and al, 7fh
	cmp al, [rbx+o_Name]
	pop rax
	je .match
	mov rbx, [rbx+o_Link]
	jmp .find1
;# _match:               #                        AC
.match:
	test al, BI_EXEC
	jz COMPL
	jmp qword [rbx]

;######################### Interpreter subroutines ################################################
.subs:
macro command name, [lbl, flags] {
local string
local size
	db 99h
if flags eq
	db size
else
	db size or flags
end if
	string db `name
	size = $ - string
if lbl eq
label name
else
label lbl
end if
}
macro bi_call [name] {
local char
virtual at 0
	db `name
	load char from 0
end virtual
	db 99h, char
}
macro bi_exec [name] {
local char
virtual at 0
	db `name
	load char from 0
end virtual
	db 99h, char or BI_EXEC
}

;99 05 43 4F 4D 50 4C #### COMPL Forth's COMPILE, B9 ( ebx=xt -- )
command COMPL
	mov al, 0ffh
	stosb ;B0 FF AA                # compile >>>>>>>>>>>>>>>>> call r/m64          FF /2           00 010 100  00 100 101
	mov al, 14h
	stosb ;B0 14 AA                #     al = _                mov r8, imm8        B0+rb ib
	mov al, 25h
	stosb ;B0 25 AA                #         [rdi++] = al      stos m8             AA
	xchg eax, ebx
	stosd
	ret

;99 04 48 65 61 64 ####### Head ================= CB ( al=flag rdx=Latest rsi=addr -- rdx=Latest rsi=addr' )
command Head
	add rdi, 0fh
	and rdi, 0xfffffffffffffff0
	mov rcx, [rdx]
	mov [rdi+o_Link], rcx
	mov [rdx], rdi
	add rdi, o_LengthFlag
	stosb
	xchg eax, ecx
	and ecx, 1fh
	rep movsb
	mov rcx, [rdx]
	mov [rcx+o_Code], rdi
	ret
;
;# ============= DICTIONARY FORMAT
;#
;# Each SmithForth dictionary entry begins with:
virtual at 0
;#     (8 bytes)         Code
	o_Code = $ - $$
	rq 1
;#     (8 bytes)         Link
	o_Link = $ - $$
	rq 1
;#     (1 byte)          Flag (3 bits) and Length (5 bits) of Name
	o_LengthFlag = $ - $$
	rb 1
	o_Name = $ - $$
end virtual
;#     (Length bytes)    Name, where Length < 2^5.
;# Each subroutine call refers to its callee. See argument ZZ in the following example:
;#
;# WW WW WW WW WW WW WW WW # Code: address of a subroutine (usually right after Name)
;# XX XX XX XX XX XX XX XX # Link: address of the next earlier dictionary entry
;# YY                      # Flag: 80=IMMEDIATE, 40=HIDDEN ; Name Length
MASK_Length equ 1fh
IMMEDIATE equ 80h
HIDDEN equ 40h
;# 2E 53                   # Name: .S ( -- ) show the values on the data stack
;# 4D 89 7F F8             # [r15-8] = r15 (obuf)      mov r/m64, r64      REX.W 89 /r     01 111 111
;# 49 C7 47 F0 00 00 00 10 # [r15-10] = 10000000 (len) mov r/m64, imm32    REX.W C7 /0 id  01 000 111
;# 4D 29 7F F0             # [r15-10] -= r15           sub r/m64, r64      REX.W 29 /r     01 111 111
;# 49 83 EF 10             # r15 -= 2 cells            sub r/m64, imm8     REX.W 83 /5 ib  11 101 111
;# FF 14 25 ZZ ZZ ZZ ZZ    # call TYPE                 call r/m64          FF /2           00 010 100  00 100 101
;# C3                      # return                    ret                 C3
;
;99 03 42 59 45 ########## BYE ( -- ) =============================================================
command BYE
	push 3ch
	pop rax
	xor edi, edi
	syscall

if 0
	bi_exec BYE
end if

;# Linux syscall: ( RDI RSI RDX R10 R8 R9 RAX=syscall# -- RAX=stat RCX=? R11=? )
;#     Manual pages on system calls: `man 2 syscalls ; man 2 exit ; man 2 read ; man 2 write ; man 2 mmap`
;#     syscall numbers: /usr/include/x86_64-linux-gnu/asm/unistd_64.h
;#     syscall error numbers: /usr/include/asm-generic/errno-base.h
;#     mmap flag values: /usr/include/asm-generic/mman-common.h
;
;99 04 54 59 50 45 ####### TYPE ( rsi=addr rdx=u -- rsi=? rdi=? ) show memory [addr, addr+u) ======
command TYPE
	push 1
	pop rdi
;# _beg:                 #                        00
.beg:
;8B C7                   # rax = write = 1 = rdi     mov r32, r/m32      8B /r           11 000 111
	db 0x8b, 0xc7
;	mov eax, edi;fasm assembles it as 89 F8   <- mov r/m32, r32      89 /r           11 111 000
	syscall
	test rax, rax
	jl .end
	add rsi, rax
	sub rdx, rax
	jg .beg
;# _end:                 #                        11
.end:
	ret

;# ============= DEBUGGING
;#
;# During development, a program like this one may crash with an uninformative error message like
;# "Segmentation fault" or "Illegal instruction." How can we work in such an environment?
;# We start with a trivial program that works (i.e., simply invokes syscall exit, as in BYE),
;# and then expand it gradually until it does what we want. When a program breaks after a small
;# change, we know where the bug is. Here is one way to go.
;#
;# Insert a jump to BYE at the top of the program. You have to compute the length of the jump.
;# After this chore, updating it is easy if you expand the program only one instruction at a time.
;# You will want to disable and enable parts of the program as you expand it. The most basic ways:
;# -- Hide unwanted code in comments. If this disrupts byte counts, replace lost bytes by no-op
;#    instructions NOP = 90.
;# -- Inside a subroutine, leave early by inserting a return instruction RET = C3.
;
;99 03 64 62 67 ########## dbg ( -- ) show stack and data; use `./SForth | xxd -o 0x0fffffe0` =====
command dbg
	push rsi rdi
	mov esi, 0fffffe0h
	mov edx, 00000a00h
	bi_call TYPE
	pop rdi rsi
	ret

if 0
	bi_exec dbg, BYE
end if

;99 03 72 65 67 ########## reg ( -- ) show registers; use `./SForth | xxd` ========================
command reg
	push rsi rdi
	push r15 rdi r14 rsi
	push r13 rbp r12 rsp
	push r11 rbx r10 rdx
	push r9 rcx r8 rax
;48 8B F4                # rsi = rsp                 mov r64, r/m64      REX.W 8B /r     11 110 100
	db 0x48, 0x8b, 0xf4
;	mov rsi, rsp;fasm assembles it as 49 89 E6<- mov r/m64, r64      REX.W 89 /r     11 100 000
	mov edx, 80h
	bi_call TYPE
	sub rsp, -80h
	pop rdi rsi
	ret

if 0
	bi_exec reg, BYE
end if

;# ============= TEXT INTERPRETER
;#
;# Standard Forth handles input one line at a time.
;# SmithForth's text interpreter is a simple interpreter in the standard Forth style.
;# SVAL (see standard Forth's EVALUATE) interprets each line.
;# REFILL fetches a line of input, including its trailing LF, and sets the input source state.
virtual at 10000000h
Input:
;#     10000000 #IN      cell contains #characters in the current line.
	o_nIN = $ - $$
	nIN rq 1
;#     10000008 TIB      cell contains the address where the current line begins.
	o_TIB = $ - $$
	TIB rq 1
;#     10000010 >IN      cell contains #characters in the current line that have been parsed.
	o_pIN = $ - $$
	pIN rq 1
	rq 1
;#     10000020 STATE    cell contains 0(Interpreting) or 1(Compiling).
	STATE rq 1
Interpreting equ 0
Compiling equ 1
;#     10000028 Latest   cell contains the execution token (xt) of the latest defined Forth word.
	Latest rq 1
Dictionary:
end virtual
;# In Forth, to parse is to remove from the input stream. As a line is parsed, [>IN] increases from 0 to [#IN].
;# Forth's "parse area" is the part of the line not yet parsed.

;99 06 52 45 46 49 4C 4C # REFILL ( -- ) ==========================================================
command REFILL
	mov r9, Input
	mov rax, [r9+o_nIN]
	add [r9+o_TIB], rax
	and qword [r9+o_nIN], 0
	and qword [r9+o_pIN], 0
;# _beg:                 #                        00
.beg:
	inc qword [r9+o_nIN]
	mov rax, [r9+o_TIB]
	add rax, [r9+o_nIN]
	cmp byte [rax-1], 10
	jne .beg
	ret

;99 04 73 65 65 6B ####### seek ( cl dl "ccc" -- eflags ) parse until 1st char of parse area is within [cl, dl) or parse area is empty
command seek
	mov r9, Input
;2A D1                   # dl -= cl                  sub r8, r/m8        2A /r           11 010 001
	db 0x2a, 0xd1
;	sub dl,cl;fasm assembles it as 28 CA      <- sub r/m8, r8        28 /r           11 001 010
;# _beg:                 #                        00                 like WITHIN ( al cl dl -- eflags )
.beg:
	mov rax, [r9+o_pIN]
	cmp rax, [r9+o_nIN]
	jae .end
	mov rax, [r9+o_TIB]
	add rax, [r9+o_pIN]
	mov al, [rax]
;2A C1                   # al -= cl                  sub r8, r/m8        2A /r           11 000 001
	db 0x2a, 0xc1
;	sub al, cl;fasm assembles it as 28 C8     <- sub r/m8, r8        28 /r           11 001 000
;3A C2                   # cmp al, dl                cmp r8, r/m8        3A /r           11 000 010
	db 0x3a, 0xc2
;	cmp al, dl;fasm assembles it as 38 D0     <- cmp r/m8, r8        38 /r           11 010 000
	jb .end
	inc qword [r9+o_pIN]
	jmp .beg
;# _end:                 #                        1F
.end:
	ret
;
;99 05 50 41 52 53 45 #### PARSE ( cl dl "ccc<char>" -- rbp=addr rax=u ) addr: where ccc begins ; u: length of ccc
command PARSE
	mov r9, Input
	mov rbp, [r9+o_pIN]
	bi_call seek
	mov rax, [r9+o_pIN]
	jae .end
	inc qword [r9+o_pIN]
;# _end:                 #                        04
.end:
	sub rax, rbp
	add rbp, [r9+o_TIB]
	ret

;99 05 70 6E 61 6D 65 #### pname ( "<spaces>ccc<space>" -- rbp=addr rax=u ) PARSE-NAME ============
command pname
	mov cl, ' '+1
	mov dl, 7fh
	bi_call seek
	mov cl, 7fh
	mov dl, ' '+1
	bi_call PARSE
	ret

;99 81 5B ################ [ ( -- ) lbracket IMMEDIATE ============================================
command '[', lbracket, IMMEDIATE
	push Interpreting
	pop [qword STATE];pop [STATE]
	ret

;99 01 5D ################ ] ( -- ) rbracket ======================================================
command ']', rbracket
	push Compiling
	pop [qword STATE];pop [STATE]
	ret

;99 81 5C ################ \ ( "ccc<eol>" -- ) backslash IMMEDIATE ================================
command '\', backslash, IMMEDIATE
;48 8B 04 25 00 00 00 10 # rax = [#IN]               mov r64, r/m64      REX.W 8B /r     00 000 100  00 100 101
	db 0x48, 0x8b, 0x04, 0x25, 0x00, 0x00, 0x00, 0x10;mov rax, [nIN]
;	mov rax, [qword nIN];fasm 48 A1 00000010   <-mov rax, moffs64    REX.W A1 id
;48 89 04 25 10 00 00 10 # [>IN] = rax               mov r/m64, r64      REX.W 89 /r     00 000 100  00 100 101
	db 0x48, 0x89, 0x04, 0x25, 0x10, 0x00, 0x00, 0x10;mov [pIN], rax
;	mov [qword pIN], rax;fasm 48 A3 10000010.00<-mov moffs64, rax    REX.W A3 iq
	ret

;99 81 28 ################ ( ( "ccc<rparen>" -- ) lparen IMMEDIATE ================================
command '(', lparen, IMMEDIATE
	mov cl, ')'
	mov dl, ')'+1
	bi_call PARSE
	ret

;99 01 3A ################ : ( "<spaces>ccc<space>" -- ) colon ====================================
command ':', colon
;99 70                   # Call pname                            See Forth 2012 Table 2.1
	bi_call pname
	mov rsi, rbp
	mov edx, Latest
	bi_call Head
	mov rcx, [rdx]
	add rcx, o_LengthFlag
	or byte [rcx], HIDDEN
	bi_call ']'
	ret
;
;99 81 3B ################ ; ( C: -- ) semicolon IMMEDIATE ========================================
command ';', semicolon, IMMEDIATE
;B0 C3                   # al = opcode ret           mov r8, imm8        B0+rb ib
virtual at 0
	ret
	load opret from 0
end virtual
	mov al, opret
	stosb
	mov rcx, [qword Latest];mov rcx, [Latest]
	add rcx, o_LengthFlag
	and byte [rcx], not HIDDEN
	bi_call '['
	ret

;99 01 2E ################ . ( char -- ) nonstandard name for C, ==================================
command '.', nonstandarddot
	mov al, [r15]
	add r15, 8
	stosb
	ret

;99 83 4C 49 54 ########## LIT ( C: x -- ) ( -- x ) IMMEDIATE ===================================== TODO compare xchg r15, rsp ; push imm8 ; xchg r15, rsp
command LIT,, IMMEDIATE
;B8 49 83 EF 08 AB       # compile r15 -= 8          sub r/m64, imm8     REX.W 83 /5 ib  11 101 111
	mov eax, 08ef8349h
	stosd
;B8 6A 41 8F 07 AA       # eax = push x ; pop [r15]  push i8 ; pop r/m64 6A ib;REX 8F /0 00 000 111
	mov eax, 078f416ah
	stosb
;41 8A 07 AB             # al = [r15] ; compile      mov r8, r/m8        REX 8A /r       00 000 111
	mov al, [r15]
	stosd
	add r15, 8
	ret

;99 03 78 74 3D ########## xt= ( rbp=addr rax=u rbx=xt -- rbx=xt rax=? rdi=? eflags ) rbx == 0 or unhidden and matches
command 'xt=', xtequals
	test rbx, rbx
	jnz .nonzero
	ret
;# _nonzero:             #
.nonzero:
;48 8B C8                # rcx = rax(u)              mov r64, r/m64      REX.W 8B /r     11 001 000
	db 0x48, 0x8b, 0xc8
;	mov rcx, rax;fasm assembles it as 49 89 C1<- mov r/m64, r64      REX.W 89 /r     11 000 001
	lea rsi, [rbx+o_LengthFlag]
	lodsb
	test al, HIDDEN
	jz .unhidden
	ret
;# _unhidden:            #
.unhidden:
	and rax, MASK_Length
	cmp rax, rcx
	je .lengthEq
	ret
;# _lengthEq:            #                          
.lengthEq:
;48 8B FD                # rdi = rbp                 mov r64, r/m64      REX.W 8B /r     11 111 101
	db 0x48, 0x8b, 0xfd
;	mov rdi, rbp;fasm assembles it as 49 89 EF<- mov r/m64, r64      REX.W 89 /r     11 101 111
	repe cmpsb
	ret
;
;99 04 46 49 4E 44 ####### FIND ( rbp=addr rax=u -- rbp=addr rax=u rbx=xt ) xt==0 if not found ====
command FIND
	mov rbx, [qword Latest];mov rbx, [Latest]
;# _beg:                 #
.beg:
	call .FIND
	jne .beg
	ret
;# # # # # # # # # # # # # (FIND)
.FIND:
	push rax rdi
	bi_call 'xt='
	pop rdi rax
	je .end
	mov rbx, [rbx+8]
;# _end:                 #
.end:
	ret

;99 03 4E 75 6D ########## Num ( rbp=addr rax=u -- n ) ============================================
command Num
	sub r15, 8
	and qword [r15], 0
	mov rcx, rax
;48 8B F5                # rsi = rbp                 mov r64, r/m64      REX.W 8B /r     11 110 101
	db 0x48, 0x8b, 0xf5
;	mov rsi, rbp;fasm assembles it as 49 89 EE<- mov r/m64, r64      REX.W 89 /r     11 101 110
;# _beg:                 #                        
.beg:
	call .Num
	loop .beg
	ret
;# # # # # # # # # # # # # (Num)
.Num:
	lodsb
	cmp al, 'A'
	jl .digit
;# _letter:              #
.letter:
	sub al, 7
;# _digit:               #
.digit:
	sub al, 30h
	sal qword [r15], 4
	or qword [r15], rax
	ret

;99 04 6D 69 73 73 ####### miss ( rbp=addr rax=u rbx=xt -- |n rbx=xt ) n present iff u nonzero ====
command miss
	test rbx, rbx
	jz .miss
	ret
;# # # # # # # # # # # # # (miss)
.miss:
	test rax, rax
	jne .nonempty
	ret
;# _nonempty:            #
.nonempty:
	bi_call Num
	test byte [qword STATE], 1;test byte [STATE], 1
	jnz .lit
	ret
;# _lit:                 #
.lit:
	bi_call LIT
	ret

;99 04 45 58 45 43 ####### EXEC ( rbx=xt -- ) =====================================================
command EXEC
	mov ecx, 7ffffff8h
	push rdi
	mov edi, ecx
	bi_call COMPL
	mov al, 0xc3
	stosb
	pop rdi
	call rcx
	ret

;99 04 65 78 65 63 ####### exec ( al rbx=xt -- ) iff al != 1 ======================================
command exec
	cmp al, 1
	jne .exec
	ret
;# # # # # # # # # # # # # (exec)
.exec:
	bi_call EXEC
	ret

;99 05 63 6F 6D 70 6C #### compl ( al -- al ) iff al == 1 ==========================================
command compl
	cmp al, 1
	je .compl
	ret
;# # # # # # # # # # # # # (compl)
.compl:
	bi_call COMPL
	mov al, 1
	ret

;99 03 68 69 74 ########## hit ( rbx=xt -- ) ======================================================
command hit
	test rbx, rbx
	jnz .hit
	ret
;# # # # # # # # # # # # # (hit)
.hit:
	db 40h;40 8A 43 10             # al = [rbx+10]             mov r8, r/m8        REX 8A /r       01 000 011
	mov al, [rbx+o_LengthFlag]
	and al, IMMEDIATE
	or al, byte [qword STATE];or al, byte [STATE]
	bi_call compl, exec
	ret

;99 04 53 56 41 4C ####### SVAL ( i*x -- j*x ) == 00 EVALUATE =====================================
command SVAL
;E8 03 00 00 00          #+call (SVAL)            05 call rel32          E8 cd
	call .SVAL
;7C F9                   #-jump SVAL if <         07 jl rel8             7C cb
	jl SVAL
;C3                      # return                    ret                 C3
	ret
;# # # # # # # # # # # # # (SVAL)                 08
.SVAL:
;99 70                   # Call pname
;99 46                   # Call FIND
;99 6D                   # Call miss
;99 68                   # Call hit
	bi_call pname, FIND, miss, hit
;48 8B 04 25 10 00 00 10 # rax = [>IN]               mov r64, r/m64      REX.W 8B /r     00 000 100  00 100 101
	db 0x48, 0x8B, 0x04, 0x25, 0x10, 0x00, 0x00, 0x10;mov rax, [pIN]
;	mov rax, [qword pIN];fasm  48 A1 10000010 <- mov rax, moffs64    REX.W A1 id
;48 3B 04 25 00 00 00 10 # cmp rax, [#IN]            cmp r64, r/m64      REX.W 3B /r     00 000 100  00 100 101
	cmp rax, [qword nIN];cmp rax, [nIN]
;C3                      # return                    ret                 C3
	ret

;99 02 74 69 ############# ti ( -- ) text interpreter =============================================
command ti
	mov r15, Input
	mov [r15+o_TIB], rsi
	bi_call '['
.beg:
	call .ti
	jmp .beg
;# # # # # # # # # # # # # (ti)
.ti:
	bi_call REFILL, SVAL
	ret

if 0
	bi_exec dbg, BYE
end if

bi_exec ti
file '../system.fs'