; 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 ..10x
	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 ..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
.a:	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 .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
