path: root/jefs.s

; jewelforth

;; MACROS {{{
%macro pspush 1
	lea r14, [r14-8]
	mov qword [r14], %1
%endmacro

%macro pspop 1
	mov %1, qword [r14]
	lea r14, [r14+8]
%endmacro

;;; dictionary macros {{{
%define mac_latest	0	; updated through defdict

%macro defdict 3 ; name asm-label flags
	%strlen slen %1
	global lfa_%2
	lfa_%2: dq mac_latest
		%define mac_latest lfa_%2
	ffa_%2:	db %3 ; FFA
	nfa_%2:	dw slen ; NFA
		db %1
%endmacro

%macro defword 3
	defdict %1, %2, %3
	%2:
%endmacro

%macro defconst 4 ; ... value
	defdict %1, %2, %3
	%define %2 %4
	pspush qword %4
	ret
%endmacro

%macro defvar 4 ; ... default-value
	%2: dq %4
	defdict %1, %2, %3
	pspush qword %2
	ret
%endmacro

%assign smudge_mask	0x1
%assign immediate_mask	0x2

%assign false 0x0
%assign true 0xffffffffffffffff

%assign interpreting 0x0
%assign compiling 0xffffffffffffffff
;;; }}}

;; syscall
%assign	__NR_read	0
%assign	__NR_write	1
%assign	__NR_brk	12
%assign	__NR_exit	60
;; }}}

section .bss exec
wstack_b:	resq 2047
wstack:		resq 1

umem:	resb 0x9c400
umem_e:

section .text
global _start
_start:
	; init
	mov r14, wstack ; point SP to top

	call interpret
	mov rdi, 0
	mov rax, __NR_exit
	syscall

defword "bye", bye, 0
	mov rdi, 0
	mov rax, __NR_exit
	syscall
	ret ; will not be reached

defword "@", fetch, 0
	pspop r11
	mov r12, qword [r11]
	pspush r12
	ret

defword "c@", cfetch, 0
	pspop r11
	xor r12, r12
	mov r12b, [r11]
	pspush r12
	ret

defword "!", store, 0
	pspop r11
	pspop r12
	mov qword [r11], r12
	ret

defword "c!", cstore, 0
	pspop r11
	pspop r12
	mov [r11], r12b
	ret

defword ",", comma, 0
	pspop r11
	mov r12, [here]
	mov qword [r12], r11
	add r12, 8
	mov qword [here], r12
	ret

defword "w,", w_comma, 0
	pspop r11
	mov r12, [here]
	mov word [r12], r11w
	add r12, 2
	mov qword [here], r12
	ret

defword "c,", c_comma, 0
	pspop r11
	mov r12, [here]
	mov byte [r12], r11b
	inc r12
	mov qword [here], r12
	ret

; stage 1 parser. very rudimentary,
; since it will only parse a little bit of the init file
; there won't be much error checking either.
defword "parse", parse, 0
	mov r13, qword [to_in]
	add r13, initfile
	mov r12b, byte [r13]

.wsloop: ; skip initial ws
	cmp r12b, 0x20
	je .wsloop_cont
	cmp r12b, 0x0a
	jne .wordloop_start
.wsloop_cont:
	inc r13
	mov r12b, byte [r13]
	jmp .wsloop

.wordloop_start:
	push r13 ; keep start address of this word for later
	mov r11, 1 ; W: word length count
.wordloop:
	cmp r12b, 0x20
	je .wordloop_end
	cmp r12b, 0x0a
	je .wordloop_end

	inc r11
	inc r13
	mov r12b, byte [r13]
	jmp .wordloop

.wordloop_end:
	dec r11
	sub r13, initfile
	mov qword [to_in], r13
	pop r13
	pspush r13 ; c-addr
	pspush r11 ; u
	ret

defword "find", find, 0
	pspop r10 ; u
	pspop r11 ; c-addr
	mov r12, latest
	mov r13, qword [r12]
	mov r12, r13

.check_smudge:
	add r13, 8
	mov r9b, byte [r13]
	test r9b, smudge_mask
	jnz .no

.no_smudge:
	inc r13
	mov r9w, word [r13]
	cmp r9w, r10w
	jne .no
	mov rsi, r13
	add rsi, 2
	mov rdi, r11
	mov rcx, r10
	repz cmpsb
	jnz .no
	sub r13, 9
	pspush r13
	mov r13, true
	pspush r13
	ret

.no:
	mov r13, qword [r12]
	mov r12, r13
	cmp r13, 0 ; end of dictionary? fallthrough to notfound if so
	jne .check_smudge

	mov r13, false
	pspush r13
	ret

; stage 1 interpreter, just reads from initfile
defword "interpret", interpret, 0
.loop:
	call parse
	call twodup
	call find
	mov r12, qword [state]
	cmp r12, compiling
	je .compile

.interp:
	pspop r11
	cmp r11, false
	je .interp_n

	call to_cfa
	pspop r15
	call twodrop
	; pspush r15
	; pspop r11
	call r15
	jmp .loop
	ret ; unreachable safety RET

.interp_n:
	call number
	pspop r11
	jmp .loop
	ret

.compile:
	; call dots
	pspop r11
	cmp r11, false
	je .comp_n

	; handle immediates
	; call dots
	pspop r15
	call twodrop
	pspush r15
	call dup
	; call dots
	call immediate_q
	; call dots
	pspop r13
	cmp r13, true
	je .immed_comp

	call to_cfa
	; call dots
	call compile_comma
	jmp .loop
	ret ; unreachable safety RET

.immed_comp:
	call to_cfa
	pspop r11
	call r11
	jmp .loop
	ret

.comp_n:
	call number
	pspop r11 ; assume its a valid number for now
	call lit
	jmp .loop
	ret

defword "immediate?", immediate_q, 0 ; ( lfa -- flag )
	pspop r11
	add r11, 8
	mov r12b, byte [r11]
	pspush r11
	pspush r12
	mov r13b, immediate_mask
	pspush r13
	; call dots
	call twodrop
	pspop r11
	test r12b, immediate_mask
	jnz .imm

	mov r11, false
	pspush r11
	ret

.imm:
	; call dots
	mov r11, true
	pspush r11
	ret

defword ">cfa", to_cfa, 0
	pspop r11
	add r11, 9
	xor r12, r12
	mov r12w, word [r11]
	add r11, 2
	add r11, r12
	pspush r11
	ret

defword "compile,", compile_comma, 0
	pspop r11
	mov r12, [here]

	; compile mov r11, [cfa]
	mov word [r12], 0xbb49
	add r12, 2
	mov qword [r12], r11
	add r12, 8

	; compile call r11
	mov word [r12], 0xff41
	add r12, 2
	mov byte [r12], 0xd3
	inc r12

	mov qword [here], r12
	ret

defword ":", colon, 0
	call parse
	pspop r9 ; u
	pspop r10 ; c-addr
	mov r11, [latest]
	mov r12, [here]
	push r12 ; keep for LATEST

	mov qword [r12], r11
	add r12, 8
	mov byte [r12], smudge_mask
	inc r12
	mov word [r12], r9w ; r9w from r9: safe?
	add r12, 2

	; strcpy
	mov rcx, r9
	mov rsi, r10
	mov rdi, r12
	rep movsb
	add r12, r9

	mov qword [here], r12
	pop r12
	mov qword [latest], r12
	mov qword [state], compiling
	ret

defword ";", semicolon, immediate_mask
	; unsmudge
	mov r12, [latest]
	add r12, 8
	mov r13b, [r12]
	mov r15b, smudge_mask ; todo figure out how to do this at assemble time
	not r15b
	and r13b, r15b
	mov byte [r12], r13b

	mov r11, [here]
	mov byte [r11], 0xc3 ; RET
	inc r11
	mov qword [here], r11
	mov qword [state], interpreting
	ret

defword "number", number, 0 ; ( c-addr u -- ?n flag )
	pspop r11 ; u
	pspop r12 ; c-addr
	xor r13, r13 ; r13: result
	xor r15, r15 ; r15b: current char

	cmp r11, 0
	je .no

.loop:
	mov r15b, byte [r12]

	; non numeral = goodbye
	cmp r15b, 48
	jl .no
	cmp r15b, 57
	jg .no

	imul r13, 10
	sub r15b, 48
	add r13, r15

	inc r12
	dec r11

	cmp r11, 0
	jne .loop

	pspush r13
	mov r13, true
	pspush r13
	ret

.no:
	mov r13, false
	pspush r13
	ret

defword "lit", lit, immediate_mask ; C: ( n -- ) ( -- n )
	; apparently u cant MOV a 64 bit immediate value to a 64 bit register?
	; what the fuck?
	; so we have to do something liike in COMPILE, where we
	; move to a register first:
	; lea r14, [r14-8]		4D 8D 76 F8
	; mov r11, 0xfefefefefefeffff	49 BB [LIT]
	; mov qword [r14], r11		4D 89 1E
	pspop r11
	mov r12, [here]

	mov dword [r12], 0xf8768d4d
	add r12, 4
	mov word [r12], 0xbb49
	add r12, 2
	mov qword [r12], r11
	add r12, 8
	mov word [r12], 0x894d
	add r12, 2
	mov byte [r12], 0x1e
	inc r12

	mov qword [here], r12
	ret

defword "syscall0", syscall0, 0 ; ( id -- rax )
	pspop rax
	syscall
	pspush rax
	ret

defword "syscall1", syscall1, 0 ; ( rdi id -- rax )
	pspop rax
	pspop rdi
	syscall
	pspush rax
	ret

defword "syscall2", syscall2, 0 ; ( rsi rdi id -- rax )
	pspop rax
	pspop rdi
	pspop rsi
	syscall
	pspush rax
	ret

defword "syscall3", syscall3, 0 ; ( rdx rsi rdi id -- rax )
	pspop rax
	pspop rdi
	pspop rsi
	pspop rdx
	syscall
	pspush rax
	ret

; these stack wrangling words are dreadfully inefficient right now
; i will come back and make these less terrible later
defword "dup", dup, 0
	mov r11, [r14]
	pspush r11
	ret

defword "2dup", twodup, 0 ; ( a b -- a b a b )
	; todo inefficient
	pspop r11
	pspop r12

	pspush r12
	pspush r11
	pspush r12
	pspush r11
	ret

defword "swap", swap, 0
	pspop r11
	pspop r12

	pspush r11
	pspush r12
	ret

defword "over", over, 0
	; TODO inefficient (use r14 ptr arith to only push once)
	pspop r11
	pspop r12

	pspush r11
	pspush r12
	pspush r11
	ret

defword "r>", from_r, 0
	pop r11
	pspush r11
	ret

defword ">r", to_r, 0
	pspop r11
	push r11
	ret

defword "drop", drop, 0
	pspop r11
	ret

defword "2drop", twodrop, 0
	pspop r11
	pspop r11
	ret

defword "rdrop", rdrop, 0
	pop r11
	ret

defword "[", lbrac, immediate_mask
	mov qword [state], interpreting
	ret

defword "]", rbrac, immediate_mask
	mov qword [state], compiling
	ret

defword "\", backslash, immediate_mask
	mov r13, qword [to_in]
	add r13, initfile
	mov r12b, byte [r13]
.loop:
	cmp r12b, 0x0a
	je .done

	inc r13
	mov r12b, byte [r13]
	jmp .loop

.done:
	inc r13
	sub r13, initfile
	mov qword [to_in], r13
	ret

defword "(", bracket, immediate_mask
	mov r13, qword [to_in]
	add r13, initfile
	mov r12b, byte [r13]
.loop:
	cmp r12b, 0x29
	je .done

	inc r13
	mov r12b, byte [r13]
	jmp .loop

.done:
	inc r13
	sub r13, initfile
	mov qword [to_in], r13
	ret

; TEMPORARY HORRIBLE DEBUGGING BULLSHIT {{{
; debugging word; outputs raw bytes so needs to be piped through `x(x)d`
; terrible and awful
; W = r14; W <= wstack_b; W+=8
defword ".s", dots, 0
	push r11
	push r12

	mov r12, r14
.loop:
	cmp r12, wstack
	jge .done

	mov [.space], r12
	mov rdx, 8 ; qword
	mov rsi, .space
	mov rdi, 1
	mov rax, __NR_write
	syscall

	mov rdx, 8 ; qword
	mov rsi, r12
	mov rdi, 1
	mov rax, __NR_write
	syscall
	lea r12, [r12+8]
	jmp .loop

.done:
	mov rdx, 16 ; 2 qword
	mov rsi, .dmsg
	mov rdi, 1
	mov rax, __NR_write
	syscall

	pop r12
	pop r11
	ret
.space: resq 1
.dmsg: db "DONEDONEYIPPEEEE"

defword "TESTSTR", teststr, 0
	mov r11, .msg
	pspush r11
	mov r11, 11
	pspush r11
	ret
.msg: db "test string"

defword "HEREDUMP", heredump, 0
	mov rdx, [here]
	mov r11, [h0]
	sub rdx, r11
	mov rsi, [h0]
	mov rdi, 1
	mov rax, __NR_write
	syscall
	ret
; }}}

defvar ">in", to_in, 0, 0
defvar "state", state, 0, interpreting
defvar "here", here, 0, umem
defvar "h0", h0, 0, umem ; beginning of user memory area
defvar "hend", hend, 0, umem_e ; ending of user memory area
defvar "latest", latest, 0, lfa_latest

initfile:
incbin "jefs.fs"
initlen equ $ - initfile
initfile_end: