; RetroForth
; Release 6.25
; ----------------------------------------------------------------------


; ----------------------------------------------------------------------
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		; ( See if it's defined in the "forth" )
	jnc .exec		; ( vocabulary )
	call dfind		; ( See if it's in the "domain" vocab )
	jnc .exec
	call number		; ( No? Then 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 )
next
; ----------------------------------------------------------------------
mfind:	push ebx
	mov ebx, mlast
	jmp find.o
; ----------------------------------------------------------------------
dfind:	push ebx
	mov ebx, dlast
	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
next
; ----------------------------------------------------------------------
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]
next
; ----------------------------------------------------------------------
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
next
; ----------------------------------------------------------------------
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
next
; ----------------------------------------------------------------------
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
	next
.eof:	drop
	drop
	add esp,4		; Discard caller
	pop Dword [tp]
	pop Dword [tin]
	pop Dword [source]
	next
; ----------------------------------------------------------------------
eval:	push Dword [source]
	push Dword [tin]
	push Dword [tp]
	add eax,[esi]
	upop [source]
	upop [tin]
	jmp interpret
next
; ----------------------------------------------------------------------
code 'if', m_if
	upsh 0x74adc085
	call comma
	upsh [h]
	upop [if_resolve]
	upsh 0x0
	call comma1
next
; ----------------------------------------------------------------------
code 'then', m_then
	upsh [h]
	upsh [if_resolve]
	embed '- 1 -'
	upsh [if_resolve]
	call cstore
next
; ----------------------------------------------------------------------
dovar:
	dup
	pop eax
	next
; ----------------------------------------------------------------------
; n ,
code ',', comma
	mov ecx,4
.a:	mov edx,[h]
	mov [edx],eax
	drop
	add edx,ecx
	mov [h],edx
	next
code '1,', comma1
	mov ecx,1
	jmp comma.a
code '2,', comma2
	mov ecx,2
	jmp comma.a
code '3,', comma3
	mov ecx,3
	jmp comma.a
; ----------------------------------------------------------------------
dodoes: dup
	pop eax
	xchg eax,[esp]
	next
; ----------------------------------------------------------------------
dolit:	dup
	mov eax,[esp]
	mov eax,[eax]
	add dword [esp],4
	next
; ----------------------------------------------------------------------
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
	next
; ----------------------------------------------------------------------
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 dfind
	jnc .com
	call number
	jnc .lit
	call type	; go figure
	upsh '?'
	call emit
	call cr
	call query
	next
.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
	next
; ----------------------------------------------------------------------
mcode '[', lbracket
	add esp,4
next
; ----------------------------------------------------------------------
mcode ';;', ssemi
	mov edx,[h]
	sub edx,5
	cmp byte [edx],0xE8	;CALL?
	jnz .a
	inc byte [edx]		;change to JMP
	next
.a:	mov byte [edx+5],0xC3	;RET
	inc dword [h]
next
; ----------------------------------------------------------------------
mcode ';', semi
	call ssemi
	jmp lbracket
; ----------------------------------------------------------------------
code ':', colon
	call create
	sub dword [h],5 ;undo 'call dovar'
	jmp rbracket
; ----------------------------------------------------------------------
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
	inline 0x50, 0xAD
next
; ----------------------------------------------------------------------
mcode 'repeat', loop_repeat
	inline 0x83, 0xEE, 0x04, 0x89, 0x06, 0x58
	inline 0x83, 0xEE, 0x04, 0x89, 0x06
	inline 0xB8, 0x01, 0x00, 0x00, 0x00
	inline 0x29, 0x06, 0xAD
next
; ----------------------------------------------------------------------
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
; ----------------------------------------------------------------------
code 'forth', dict_forth
	mov dword [last], flast
next
; ----------------------------------------------------------------------
code 'macro', dict_macro
	mov dword [last], mlast
next
; ----------------------------------------------------------------------
code 'domain', dict_domain
	mov dword [last], dlast
next
; ----------------------------------------------------------------------
if_resolve	dd	0
bases		db	16,2,8,255;		 $hex %bin &oct 'ascii
; ----------------------------------------------------------------------

; RetroForth
; Release 6.25
; ----------------------------------------------------------------------

; ----------------------------------------------------------------------
code 'sp@', sp_fetch
	upsh esi
next
; ----------------------------------------------------------------------
code 'cmove', _cmove
	mov ecx,eax
	drop
	mov edi,eax
	drop
	push esi
	mov esi,eax
.a:	mov edx, [esi] 
	mov [edi], edx
	inc edi
	inc esi
	loop .a
	pop esi
	drop
next
; ----------------------------------------------------------------------
code '@', fetch
	mov eax,[eax]
next
; ----------------------------------------------------------------------
code '+',plus
	add eax,[esi] ; +
	add esi,4
next
; ----------------------------------------------------------------------
code '-', subtract
	sub [esi], eax
	drop
next
; ----------------------------------------------------------------------
code '*', multiply
	mul dword [esi]
	add esi, 4
next
; ----------------------------------------------------------------------
code '/', divide
	upop ebx
	xor edx, edx
	idiv ebx
next
; ----------------------------------------------------------------------
code '.', print
	push edx
	push edi
	mov edi,esi	;edi = buffer (in stack space)
	sub edi,4
	or eax,eax	;Negative?
	jns .a
	neg eax
	upsh '-'
	call emit
.a:	xor edx,edx
	div dword [base]
	add dl,'0'
	cmp dl,'9'
	jbe .b
	add dl,7+32
.b:	dec edi
	mov [edi],dl
	or eax,eax
	jnz .a
	mov eax,edi	;Print
	upsh esi
	sub eax,edi	;# of digits
	call type
	pop edi
	pop edx
	upsh ' '	; And add one space after
	call emit	; the number
next
; ----------------------------------------------------------------------
code '!', $store
	upop edx
	mov [edx],eax
	drop
next
; ----------------------------------------------------------------------
code 'c!', cstore
	upop edx
	mov [edx], al
	drop
next
; ----------------------------------------------------------------------
code 'c@', cfetch
	upop edx
	dup
	xor eax,eax
	mov al, [edx]
next
; ----------------------------------------------------------------------
code 'type',type
	push ebx
	push ecx
	upop ecx
	upop ebx
	or ecx,ecx	; Is the count zero?
	jz .done	; If so, we can exit
.a: 	push ecx	; store the count
	dup		; Duplicate it
	xor eax,eax 	; Filter out junk bits
	mov al,[ebx]	; Obtain the byte to show
	inc ebx		; increment to the next byte
	call emit	; Show the character
	pop ecx		; Restore the count
	loop .a		; Loop, decrementing the count
.done:	pop ecx
	pop ebx
next
; ----------------------------------------------------------------------
code 'word',_word
	mov edi,[tin]	; Pointer into TIB
	mov ecx,[tp]
	sub ecx,edi
	inc ecx
	repe scasb
	dec edi
	inc ecx
	dup
	mov [esi],edi	;a
	repne scasb
	mov eax,edi
	dec eax
	sub eax,[esi]	;n
	mov [tin],edi
next
; ----------------------------------------------------------------------
code 'words',_words
	push ebx
	mov ebx, [last]
.a:	mov ebx,[ebx]
	or ebx,ebx
	jz .end
	dup
	lea eax,[ebx+8]
	dup
	movzx eax,byte [eax]
	inc dword [esi]
	call type
	upsh 32
	call emit
	jmp .a
.end:	pop ebx
next
; ----------------------------------------------------------------------
code '.s', _dot_s
	pusha
	embed 'depth'
	cmp eax, 0
	jle .done
	cmp eax, 300
	jg .done
	upop ecx
	mov  ebp, sp0
	sub  ebp, 4
.a:	sub ebp, 4
	dup
	mov eax,[ebp]
	call print
	loop .a
.done:	drop
	popa
next
; ----------------------------------------------------------------------
code 'reset', _reset
	mov esi, sp0
next
; ----------------------------------------------------------------------
code 'swap', _swap
	db 0x87, 0x06
next

code 'mod', _mod
	upop ebx
	xor edx,edx
	idiv ebx
	mov eax,edx
next

code '=', equals
	sub eax,[esi]                ;subtract n1 from n2
	sub eax, 1             ;see if result was 0
	sbb eax,eax
	add esi, 4
next

code '<', lessthan
	cmp eax,[esi]                ;compare them
	jl logic_less_1
	xor eax,eax                ;return result
	add esi, 4
next
logic_less_1:
	mov eax,dword -1           ;or this one :)
	add esi, 4
next

; ( address count byte )
code 'fill', fill
	upop edx
	upop ecx
	upop edi
.a:	mov [edi], edx
	inc edi
	loop .a
next
code 'sp0', _sp0
	upsh sp0
next
; ----------------------------------------------------------------------
var 'h', h, h0
var 'base', base, 10
d dd d0
source dd 0
tin dd 0
tp dd tib
; ----------------------------------------------------------------------
