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

; mem access {{{
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 "+!", plusstore, 0
	pspop r11
	pspop r12
	add qword [r11], r12
	ret

defword "-!", minusstore, 0
	pspop r11
	pspop r12
	sub qword [r11], r12
	ret

defword "d!", dstore, 0
	pspop r11
	pspop r12
	mov dword [r11], r12d
	ret

defword "w!", wstore, 0
	pspop r11
	pspop r12
	mov word [r11], r12w
	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 "d,", d_comma, 0
	pspop r11
	mov r12, [here]
	mov dword [r12], r11d
	add r12, 4
	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

defword "cmove", _cmove, 0 ; ( a1 a2 u -- )
	pspop rcx
	pspop rdi
	pspop rsi

	rep movsb
	ret

defword "cmove,", _cmove_comma, 0 ; ( c-addr u -- )
	mov r12, qword [here]

	pspop r9
	mov rcx, r9
	pspop rsi
	mov rdi, r12

	rep movsb

	add r12, r9
	mov qword [here], r12
	ret
; }}}

; note: this puts the _address it itself pushes_ on the stack
; maybe this is not the correct approach?
defword "sp", _sp, 0
	pspush r14
	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, qword [tib]
	mov r12b, byte [r13]

.wsloop: ; skip initial ws
	cmp r12b, 0x20
	je .wsloop_cont
	cmp r12b, 0x09
	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, qword [tib]
	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

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 create
	call smudge
	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

; this is basically an edited copy of :
; which should probably be rewritten to use this word
; the differences:
; this word does not change state
; smudge mask is not set
defword "create", create, 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], 0
	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
	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
	xor r10, r10 ; r10: negative flag
	mov r9, qword [base]

	cmp r11, 0
	je .no

	mov r15b, byte [r12]
	cmp r15b, '-'
	jnz .enterloop
	mov r10, true
	inc r12
	dec r11

.loop:
	mov r15b, byte [r12]

.enterloop:
	; non numeral = goodbye
	cmp r15b, 48
	jl .no

	sub r15b, 48
	; cmp r15b, 57
	; jg .no
	cmp r15b, 10 ; 48+10: < ':', <= '9'
	jl .basecmp
	cmp r15b, 17 ; ':' - '@'
	jl .no
	sub r15b, 7 ; keep 10 so 'A' = 10
	cmp r15b, 36 ; < '[' <= 'Z'
	jl .basecmp
	cmp r15b, 42 ; < 'a'
	jl .no
	sub r15b, 32
	cmp r15b, 36 ; < '{' <= 'z'
	jl .basecmp
	jmp .no

.basecmp:
	cmp r15, r9
	jge .no

	imul r13, r9
	add r13, r15

	inc r12
	dec r11

	cmp r11, 0
	jne .loop

	test r10, r10
	jz .bye
	neg r13

.bye:
	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

; what to compile:
; ADDR ← IP + 16
; JMP AFTER_STRING
; S c, T c, R c, ...
; [ fill AFTER_STRING ]
; PUSH ADDR
; PUSH CNT
defword "litstring", litstring, immediate_mask ; I: ( delim -- )
	pspop r11 ; delim
	mov r12, [here]

	mov byte [r12], 0xe9 ; JMP
	inc r12
	push r12
	mov dword [r12], 0x00000000 ; filler value
	; hm,, is the relative value gonna be equivalent to strlen + 1?

	pop 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

; stack {{{
defword "dup", dup, 0
	mov r11, [r14]
	pspush r11
	ret

defword "2dup", twodup, 0 ; ( a b -- a b a b )
	mov r11, [r14]
	mov r12, [r14+8]
	pspush r12
	pspush r11
	ret

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

	pspush r11
	pspush r12
	ret

defword "over", over, 0
	mov r11, [r14+8]
	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
; }}}

; math {{{
defword "+", plus, 0
	pspop r11
	pspop r12
	add r11, r12
	pspush r11
	ret

defword "-", minus, 0
	pspop r11
	pspop r12
	sub r12, r11
	pspush r12
	ret

defword "*", _times, 0
	pspop r11
	pspop r12
	imul r11, r12
	pspush r11
	ret

defword "/mod", divmod, 0
	xor rdx, rdx
	pspop r11
	pspop rax
	idiv r11
	pspush rdx
	pspush rax
	ret

defword "and", _and, 0
	pspop r11
	and [r14], r11
	ret

defword "or", _or, 0
	pspop r11
	or [r14], r11
	ret

defword "xor", _xor, 0
	pspop r11
	xor [r14], r11
	ret

defword "invert", invert, 0
	not qword [r14]
	ret
; }}}

; comparison {{{
; the 'neg' converts the sete 0x1 into 0xffff (-1) which is this forth's
; truth value
defword "=", equals, 0
	pspop r11
	pspop r12
	cmp r11, r12
	sete r13b
	movzx r11, r13b
	neg r11
	ret

defword "<>", less_greater, 0
	pspop r11
	pspop r12
	cmp r11, r12
	setne r13b
	movzx r11, r13b
	neg r11
	ret

defword "<", less, 0
	pspop r11
	pspop r12
	cmp r11, r12
	setl r13b
	movzx r11, r13b
	neg r11
	ret

defword ">", greater, 0
	pspop r11
	pspop r12
	cmp r11, r12
	setg r13b
	movzx r11, r13b
	neg r11
	ret

defword "<=", lesseq, 0
	pspop r11
	pspop r12
	cmp r11, r12
	setle r13b
	movzx r11, r13b
	neg r11
	ret

defword ">=", greatereq, 0
	pspop r11
	pspop r12
	cmp r11, r12
	setge r13b
	movzx r11, r13b
	neg 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, qword [tib]
	mov r12b, byte [r13]
.loop:
	cmp r12b, 0x0a
	je .done

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

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

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

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

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

defword "immediate", immediate, 0
	mov r12, [latest]
	add r12, 8
	mov r13b, [r12]
	mov r15b, immediate_mask
	or r13b, r15b
	mov byte [r12], r13b
	ret

defword "smudge", smudge, 0 ; TOGGLES it (follows fig-forth but i kinda dont like it)
	mov r12, [latest]
	add r12, 8
	mov r13b, [r12]
	mov r15b, smudge_mask
	xor r13b, r15b
	mov byte [r12], r13b
	ret

defword "char", char, 0
	call parse
	call drop
	pspop r12
	xor r11, r11
	mov r11b, [r12]
	pspush r11
	ret

; e9 [00 00 00 00] relative 32 bit immediate, relative to *instruction after jump*!
; note: the dummy value must be provided *by the calling word*
defword "branch", branch, 0
	mov r12, [here]
	mov byte [r12], 0xe9
	inc r12
	mov qword [here], r12
	ret

defword "0branch", zerobranch, 0
	mov r12, [here]
	mov r11, 0x4d08768d4d1e8b4d ; pspop r11, first bit of test r11, r11
	mov qword [r12], r11
	add r12, 8
	mov dword [r12], 0x840fdb85 ; rest of ^, je
	add r12, 4
	; include 32bit offset yourself
	mov qword [here], r12
	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 "TESTSTR2", teststr2, 0
	mov r11, .msg
	pspush r11
	mov r11, 12
	pspush r11
	ret
.msg: db "other 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 "tib", tib, 0, initfile
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 "base", base, 0, 10
defvar "latest", latest, 0, lfa_latest

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