; vim: ft=fasm :
if_resolve dd 0

; ( This implements the basic forth interpreter )
interpret:
.o:	call query		; ( Get a WORD )
.word:	upsh 32 		; ( Push a <SPACE> onto the stack )
	call $word		;
	jnz .find		; ( Look for the end of the line )
	drop			; ( DROP two numbers )
	drop			;
	jmp .o		; ( Loop back to start if no words found )
.find:	call find		; ( Else, Lookup the word )
	jnc .exec		; ( Execute if found )
	call number		; ( Otherwise make it a number )
	jnc .word		; ( Loop back )
	drop			; ( It wasn't a word or a number? )
	drop			; ( We'll just ignore it )
	jmp .o		; ( And Loop back )
.exec:	upop edi		; ( Ok, we found a word, so let's )
	call edi		; ( execute it )
	jmp .word	; ( And Loop back )
ret

code 'mfind', mfind
	push ebx
	mov ebx, mlast
	jmp find.o

code 'find', find
	push ebx
	mov ebx, flast
.o:	push ecx
	upop ecx
.a:	mov ebx,[ebx]
	or ebx,ebx
	jz .end
	cmp cl,[ebx+8]
	jne .a
.len:	push esi		;same length
	push edi
	push ecx
	mov esi,eax
	lea edi,[ebx+9]
	rep cmpsb
	pop ecx
	pop edi
	pop esi
	jne .a
	mov eax,[ebx+4] 	;exact match
	clc
	jmp .ret
.end:	upsh ecx		;no matches
	stc
.ret:	pop ecx
	pop ebx
	ret

number: push dword [base]
	mov ecx,eax		;n   (keep on stack in case of failure)
	mov ebx,[esi]		;a
	dup
	xor eax,eax		;the number
	xor edx,edx		;temp
	mov dl,[ebx]
	cmp dl,45		; -     Sign prefix
	pushf
	jne .a
	inc ebx
	dec ecx
	mov dl,[ebx]
.a:	sub dl,36		; $%&'  Base prefix
	cmp dl,4
	ja .b
	mov dl,[edx+bases]
	mov byte [base],dl
	inc ebx
	dec ecx
.b:	 mov dl,[ebx]		; digits
	inc ebx
	call digit
	jc .err
	loop .b
	jmp .c
.err:	add esp, 4
	drop
	stc
	jmp .ret
.c:	popf
	jne .d
	neg eax
.d:	add esi,8		; add esi,byte 4 add esi,byte 4
	clc
.ret:	pop dword [base]
	ret

bases	db 16,2,8,255		; $hex %bin &oct 'ascii
digit:	cmp byte [base],255
	je .x10
	cmp dl,57		; 9
	jbe .a
	and dl,5Fh		; uppercase
	cmp dl,65		; throw out chars between '9' and 'A'
	jb .err
	sub dl,7
.a:	sub dl,48		; 0
	cmp dl, byte [base]
	jb .x10
.err:	stc			;not a digit
	ret
.x10:	imul eax,[base]
	add eax,edx
	clc
	ret

query:	mov dword ecx,[source]
	or ecx,ecx
	jnz query_mem
	mov dword [tp],tib	; Reset TP, TIN
	mov dword [tin],tib
.a:	call key		; Get a keypress
	cmp al, 13	      ; For standard, change to 10
	je .cr			;
	cmp al, 10
	je .cr
	xchg edi,[tp]		; Store the char in the TIB
	stosb
	xchg [tp],edi
	call emit		; Show the byte
	jmp .a		; And Loop back around
.cr:	lodsd
	call cr
	ret

query_mem:
	mov edi,[tin]
	upsh edi		; Input pointer
	dup
	cmp Byte [edi],10	; Skip LF
	jne .a
	inc edi 		; Increase our pointer
.a:	mov [tin],edi
	sub ecx,edi		; Remaining length
	jbe .eof
	mov al,10		; Line Feed
	repne scasb
	mov eax,edi
	jne .b
	dec eax
	cmp Byte [eax-1],13	; We make CR optional
	jne .b
	dec eax
.b:	upop [tp]
	drop
	ret

.eof:	drop
	drop
	add esp,4		; Discard caller
	pop Dword [tp]
	pop Dword [tin]
	pop Dword [source]
	ret

eval:	push Dword [source]
	push Dword [tin]
	push Dword [tp]
	add eax,[esi]
	upop [source]
	upop [tin]
	jmp interpret
next

;---------------------------------------------------------------
mcode 'if', m_if
	upsh 0x74adc085
	call comma
	upsh [h]
	upop [if_resolve]
	upsh 0x0
	call comma1
next

mcode 'then', m_then
	upsh [h]
	upsh [if_resolve]
	embed '- 1 -'
	upsh [if_resolve]
	call cstore
next

dovar:
	dup
	pop eax
	ret
;---------------------------------------------------------------
; n ,
comma:
	 mov ecx,4
.a:	mov edx,[h]
	mov [edx],eax
	drop
	add edx,ecx
	mov [h],edx
	ret

code 'x,', usercomma
	upop ecx
	jmp comma.a
comma1: mov ecx,1
	jmp comma.a
comma2: mov ecx,2
	jmp comma.a
comma3: mov ecx,3
	jmp comma.a

dodoes: dup
	pop eax
	xchg eax,[esp]
	ret
;---------------------------------------------------------------
dolit:	dup
	mov eax,[esp]
	mov eax,[eax]
	add dword [esp],4
	ret
;---------------------------------------------------------------
code 'create', create
	upsh 32 	;Name
	call $word
	push ecx
	mov edi,[d]	;LFA
	mov ecx,[last]	;last
	mov edx,[ecx]
	mov [edi],edx	;LFA= [last]
	mov [ecx],edi	;last= LFA
	mov ecx,[h]
	mov [edi+4],ecx ;CFA= here
	mov [edi+8],al	;Length
	add edi,9
	upop ecx
	push esi
	mov esi,eax
	rep movsb
	mov [d],edi	;d= d+9+length
	pop esi
	pop ecx
	mov eax,dovar	;Code
	jmp compile

;---------------------------------------------------------------
mcode 'does>', does
	upsh pdoes
	call compile
	upsh dodoes
	jmp compile

pdoes:	dup
	mov eax,[last]	;eax= header
	mov eax,[eax]
	mov eax,[eax+4] ;eax= CFA
	pop ebx
	sub ebx,eax
	sub ebx,5
	mov [eax+1],ebx ;change "call dovar" to "call <code after does>"
	drop
	ret
;---------------------------------------------------------------
; Compiler
;
code ']', rbracket
.word:	 upsh 32
	call $word
	jnz .find	; n=0 means EOL
	drop
	drop
	call query
	jmp .word
.find:	 call mfind
	jnc .exec	; -IF
	call find
	jnc .com
	call number
	jnc .lit
	call type	; go figure
	upsh '?'
	call emit
	call cr
	call query
	ret
.exec:	 upop edi	; execute if found
	call edi
	jmp .word
.com:	 call compile
	jmp .word
.lit:	 upsh dolit
	call compile
	call comma
	jmp .word
;---------------------------------------------------------------
compile:
	sub eax,[h]
	sub eax,5
	upsh 0xE8	; CALL
	call comma1
	call comma
	ret
;---------------------------------------------------------------
; [     Stop compiling, go back to interpreter (normally precedes ']')
mcode '[', lbracket
	add esp,4
	ret
;---------------------------------------------------------------
; ;;    Compile EXIT but continue compilation
mcode ';;', ssemi
	mov edx,[h]
	sub edx,5
	cmp byte [edx],0xE8	;CALL?
	jnz .a
	inc byte [edx]		;change to JMP
	ret
.a:	 mov byte [edx+5],0xC3	;RET
	inc dword [h]
	ret
;---------------------------------------------------------------
; ;     End compilation
mcode ';', semi
	call ssemi
	jmp lbracket
;---------------------------------------------------------------
; : <name>      Define a new word & begin compiling
code ':', colon
	call create
	sub dword [h],5 ;undo 'call dovar'
	jmp rbracket


mcode '>r', to_r
  inline 0x50, 0xAD
next
mcode 'r>', r_from
  inline 0x83, 0xEE, 0x04, 0x89, 0x06, 0x58
next
mcode 'r@', r_fetch
  call r_from
  inline 0x83, 0xEE, 0x04, 0x89, 0x06
  call to_r
next

mcode 'times', loop_times
  inline 0x83, 0xEE, 0x04, 0x89, 0x06
  inline 0x83, 0xEE, 0x04, 0x89, 0x06
  inline 0xB8, 0x00, 0x00, 0x00, 0x00
  inline 0x2B, 0x06, 0x83, 0xE8, 0x01
  inline 0x19, 0xC0, 0x83, 0xC6, 0x04
  call m_if
  inline 0xAD
  call ssemi
  call m_then
  call to_r
next

mcode 'repeat', loop_repeat
  call r_from
  inline 0x83, 0xEE, 0x04, 0x89, 0x06
  inline 0xB8, 0x01, 0x00, 0x00, 0x00
  inline 0x29, 0x06, 0xAD
next
