; ( This implements the basic forth interpreter )
interpret:
.0	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 short .0		; ( 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 short .0		; ( And Loop back )
.exec	upop edi		; ( Ok, we found a word, so let's )
	call edi		; ( execute it )
	jmp short .word 	; ( And Loop back )
ret

mfind:  push ebx
	mov ebx, mlast
	jmp short find.0
code 'find', find
	push ebx
	mov ebx, flast
.0	push ecx
	upop ecx
.1	mov ebx,[ebx]
	or ebx,ebx
	jz .end
	cmp cl,[ebx+8]
	jne .1
.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 .1
	mov eax,[ebx+4]		;exact match
	clc
	jmp short .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 .1
	inc ebx
	dec ecx
	mov dl,[ebx]
.1      sub dl,36       	; $%&'  Base prefix
	cmp dl,4
	ja .2
	mov dl,[edx+bases]
	mov [base],dl
	inc ebx
	dec ecx
.2      mov dl,[ebx]    	; digits
	inc ebx
	call digit
	jc .err
	loop .2
	jmp short .3
.err    add esp,byte 4
	drop
	stc
	jmp short .ret
.3      popf
	jne .4
	neg eax
.4      add esi,byte 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 .10x
	cmp dl,57		; 9
	jbe .1
	and dl,5Fh		; uppercase
	cmp dl,65		; throw out chars between '9' and 'A'
	jb .err
	sub dl,7
.1      sub dl,48		; 0
	cmp dl,[base]
	jb .10x
.err    stc			;not a digit
	ret
.10x    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
.0	call key		; Get a keypress
	cmp al,10		; For standard, change to 10
	je .cr			; 
	xchg edi,[tp]		; Store the char in the TIB
	stosb
	xchg [tp],edi
	call emit		; Show the byte
	jmp short .0		; 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 .0
	inc edi			; Increase our pointer
.0      mov [tin],edi
	sub ecx,edi		; Remaining length
	jbe .eof
	mov al,10		; Line Feed
	repne scasb
	mov eax,edi
	jne .2
	dec eax
	cmp Byte [eax-1],13	; We make CR optional
	jne .2
	dec eax
.2      upop [tp]
	drop
	ret
.eof    drop
	drop
	add esp,Byte 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


;---------------------------------------------------------------
if_resolve dd 0

macro
code 'if', m_if
	upsh 0x74adc085
	call comma
	upsh [h]
	upop [if_resolve]
	upsh 0x0
	call comma1
next
macro
code '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
.1	mov edx,[h]
	mov [edx],eax
	drop
	add edx,ecx
	mov [h],edx
	ret
code 'x,', usercomma
	upop ecx
	jmp short comma.1
comma1: mov ecx,1
	jmp short comma.1
comma2: mov ecx,2
	jmp short comma.1
comma3: mov ecx,3
	jmp short comma.1

dodoes: dup
	pop eax
	xchg eax,[esp]
	ret
;---------------------------------------------------------------
dolit:  dup
	mov eax,[esp]
	mov eax,[eax]
	add dword [esp],byte 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

;---------------------------------------------------------------
macro
code '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,byte 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 short .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 short .word
.com    call compile
	jmp short .word
.lit    upsh dolit
	call compile
	call comma
	jmp short .word
;---------------------------------------------------------------
compile:
	sub eax,[h]
	sub eax,5
	upsh 0xE8	; CALL
	call comma1
	call comma
	ret
;---------------------------------------------------------------
; [     Stop compiling, go back to interpreter (normally precedes ']')
macro
code '[', lbracket
	add esp,byte 4
	ret
;---------------------------------------------------------------
	; ;;    Compile EXIT but continue compilation
macro
code ';;', ssemi
	mov edx,[h]
	sub edx,byte 5
	cmp byte [edx],0xE8	;CALL?
	jnz .1
	inc byte [edx]		;change to JMP
	ret
.1      mov byte [edx+5],0xC3	;RET
	inc dword [h]
	ret
;---------------------------------------------------------------
; ;     End compilation
macro
code ';', semi
	call ssemi
	jmp lbracket
;---------------------------------------------------------------
; : <name>      Define a new word & begin compiling
code ':', colon
	call create
	sub dword [h],byte 5	;undo 'call dovar'
	jmp rbracket

