Forth/PSoC Forth

        jmp start ; start Forth interpreter

;    psoc_forth.asm -- kernal 16 bit forth for PSoC 27443 - 28 pin device
;    copyright 2003, Christopher W. Burns
;    This program is free software; you can redistribute it and/or modify
;    it under the terms of the GNU General Public License as published by
;    the Free Software Foundation; either version 2 of the License, or
;    (at your option) any later version.
 
;    This program is distributed in the hope that it will be useful,
;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;    GNU General Public License for more details.
 
;    You should have received a copy of the GNU General Public License
;    along with this program; if not, write to the Free Software
;    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
; Modified 20070821   WFT Electronics   wftElectronics.com
; b001   DHD ( Bill Goodrich ) and AGSC   Denver, CO
; same licensing as above
; some slight changes and notes by Gus Calabrese and Bill Goodrich,
; in hopes of creating a workable version for newer PSOCs, like
; our CY8C29466.
 
 
;memory map
	include	"m8c.inc"
	include	"unsignedmath.inc"
	include "uart_1.inc"     ; install UART   can we install another UART ? b001
;	include "counter8_1.inc"
	include "sar1.asm"
	include "sar2.asm"
	include "sar3.asm"
	include "amp.asm"
	include "flashtemp_1.asm"
	include "flashtemp_1int.asm"
	include	"onewiresw_1.asm"
;__________________________________________________________________________________
;00|                                                                               |
;10|                                                                               |
;20|		FLASH WRITE BUFFER                                                     |
;30|_______________________________________________________________________________|
;40|		PARAMETER STACK                                                        |
;50|                                                                               |
;60|                                                                               |
;70|                                                                               |
;80|_________RETURN STACK__________________________________________________________|
;90|                                                                               |
;A0|                                                                               |
;B0|_______________________________________________________________________________|
;C0|_cnt|TEXT INPUT BUFFER                                                         |
;D0|_______________________________________________________________________________|
;E0|___IP____|____W____|___HERE__|___LAST__|_CURRENT_|bloc|loc_|_rp_|base|_IN_|____|
;F0|_________|_________|_________|_________|___T0____|____T1___|___T2____|___T3____|
IP:		equ		e0h
W:		equ		e2h
HERE:	equ		e4h
LAST:	equ		e6h
CURRENT:equ		e8h
bloc:	equ		eah
loc:	equ		ebh
rp:		equ		ech
base:	equ		edh
IN:		equ		eeh
 
T0:		equ		f8H
T1:		equ		fah
T2:		equ		fch
T3:		equ		feh
 
sp0:	equ		40h
rp0:	equ		90h
 
cnt:	equ		c0h
TIB:	equ		c1h
EOT:	equ		e0h
 
;boot block structure mirrored in RAM
vcurr:		equ	0
vlast:		equ	2
vhere:		equ	4
vbase:		equ	6
 
;--------------------------------------------------------------------------------------
;macros
;--------------------------------------------------------------------------------------
macro	next
		ljmp	_next
endm
 
macro	pushW
		ljmp	_pushW
endm
 
macro	incr
		inc	[@0+1]
		adc	[@0],0
endm		
 
macro	colon
		lcall	_colon
endm
 
macro	doCon
		lcall	_doCON
endm		
 
macro	fetch
		mov	a, [IP]
		mov	x, [IP+1]
		romx
		mov	[@0], a
		incr	IP
endm		
 
macro	pushs
		mov a,[@0]
		push a
		mov a, [@0+1]
		push a
endm
;********************************************************************************	
;pop the stack into a word register
;********************************************************************************	
macro	pops		
		pop	a				;1
		mov [@0+1], a		;2
		pop	a				;1
		mov	[@0], a			;2
endm
;********************************************************************************	
 
macro	pushr
		mov x, [rp]
		dec x
		mov a, [@0]
		mov [x], a
		dec x
		mov a, [@0+1]
		mov [x], a
		mov [rp], x
endm
 
macro	popr
		mvi	a,[rp]
		mov	[@0+1], a
		mvi	a,[rp]
		mov [@0], a
endm
 
;	header structure
;	<len><"name"><LINK address><flags>|CODE FIELD|
macro	head
		db	@0
		ds	@1
		dw	@2
		db	@3
endm		
;-------------------------------------------------------------------------------------------------		
	area	kernal16(rom,abs)
 
	org		540h
send:	M8C_DisableGInt
		push a
send0:	mov A,  REG[UART_1_TX_CONTROL_REG]
		and	a,  16
		jz	send0
		pop	a
		mov REG[UART_1_TX_INPUT_REG], a
		ret	
read_blk:	
		mov [0f8h],3ah  ;should be 3ah
		mov X,sp
		mov a,X
		add a,3		
		mov [0f9h],a    ;sp+3
		mov [0fah],[W+1]   ;block id
		mov [0fbh], 0  ;buffer pointer
		mov [0fch],15   ;clock
		mov [fdh], 0
		mov [feh], 0
		mov [ffh], 0
		mov a,01
		SSC				;erase block
		nop
		nop
		nop
		ret	
blk_write:	
		mov [0f8h],3ah  ;should be 3ah
		mov X,sp
		mov a,X
		add a,3		
		mov [0f9h],a    ;sp+3
		mov [0fah],[W+1]   ;block id
		mov [0fbh], 0  ;buffer pointer
		mov [0fch],15   ;clock
		mov [fdh], 0
		mov [feh], 0
		mov [ffh], 0
		mov a,03
		SSC				;erase block
		nop
		nop
		nop
 
		mov [0f8h],3ah       ;should be 3ah
		mov X,sp
		mov a,X
		add a,3		
		mov [0f9h],a     	 ;sp+3
		mov [0fah],[W+1]   		 ;block id
		mov [0fbh],0		 ;buffer pointer
		mov [0fch],15   	 ;clock
		mov [fdh], 0
		mov [feh], 0
		mov [ffh], 0	
		mov a,02
		SSC				;write block
		nop	
		nop
		nop
		ret		
 
start::	mov		a,sp0
		swap	a,sp						;initialize the stack
		mov	    [rp],rp0					;initialize the return stack
		lcall	OneWireSW_1_Start			;initialize one wire protocall
;********************************************************************************		
;initialize the UART
;********************************************************************************
;		or   reg[Counter8_1_CONTROL_REG],1
    	or   REG[UART_1_TX_CONTROL_REG], 1
    	or   REG[UART_1_RX_CONTROL_REG], 1
;********************************************************************************    	
	   	mov	[IP],>FORTH
	   	mov [IP+1],<FORTH					;point to the main FORTH loop
	   	mov	a, reg[8]						;check saftey is set 
;		mov a, reg[12]						;use pin 1.1 for 27143
	   	and a, 2
	   	jz	user
;********************************************************************************
;this is the default start
;********************************************************************************	   	
		mov [CURRENT],>cold					
		mov [CURRENT+1],<cold				;set current to "cold"
		next								;start FORTH
;********************************************************************************
; this is the user's start up
;********************************************************************************
user:  	mov a, >Vcurrent					
		mov x, <Vcurrent					;User's startup
		romx
		mov	[CURRENT],a						;
		mov a, >Vcurrent
		inc	x
		romx
		mov	[CURRENT+1],a
		next
;********************************************************************************
;MAIN FORTH LOOP
;fetch the vector from "current" and execute.  When done, continous loop.
;********************************************************************************		
FORTH:	dw	current,at,execute,br,FORTH		
;-------------------------------------------------------------------------------------------
;headerless words
;-------------------------------------------------------------------------------------------
;colon	IP->rstack
;		pstack->IP
;		next
;get to colon by LCALL _colon the return address pushed by LCALL is the new IP
_colon:	pushr	IP
		pops	IP
		next
;********************************************************************************		
;exit  rstack->IP
;********************************************************************************
exit:	popr	IP					;pop the return address into the instruction pointer
		next
;********************************************************************************
;br     Branch to an inline address
;********************************************************************************		
br:		fetch	W
		fetch	W+1
		mov	[IP],[W]
		mov	[IP+1],[W+1]
		next
;********************************************************************************
;zbr	Branch to an inline address if TOS is 0, otherwise skip		
;********************************************************************************
zbr:	pops	W
		mov a, [W]
		or a,[W+1]
		jz	br
pass:	add	[IP+1],2
		adc	[IP],0
		next
;********************************************************************************
;nzbr	Branch to an inline address if TOS <> 0, other wise skip
;********************************************************************************		
nzbr:	pops	W
		mov	a,[W]
		or a,[W+1]
		jnz	br
		jmp	pass
;********************************************************************************
;lit	Pushes an inline word onto the parameter stack
;********************************************************************************		
lit:	fetch W
		fetch W+1
		pushW
;********************************************************************************		
;doCON get here by LCALL _doCON  - pushs address of constant on the stack
; and then fetches constant to the stack
;********************************************************************************
_doCON:	pop	x
		pop a
		push	a
		romx
		mov [W], a
		pop	a
		inc	x
		adc	a,0
		romx
		mov [W+1],a
		pushW
;********************************************************************************		
;xquote send an counted string to the UART
;********************************************************************************
xquote:	fetch	W			;length in W
xquote_loop:
		fetch	W+1			;char->W+1
		mov a, [W+1]
		call	send		;send it out
		dec	[W]				;decrease count
		jnz xquote_loop		;if it's not zero do it again
		next				;IP points to next token
;********************************************************************************
;doTable - push the address of the next word on the stack
;********************************************************************************
macro	doTABLE
	lcall	_next
endm		
 
 
 
;-----------------------------------------------------------------------------------------------
;inner interpreter - 
;						-check for an interrupt
;						ROM[IP]->W
;						IP+2->IP
;						W->stack
;						jmp(TOS)
;	
;********************************************************************************	
_pushW:	pushs	W						;push W register
_next:	fetch	W
		fetch	W+1						;ROM[IP]->W IP+2
		pushs	W						;W-> stack
		ret								;jmp[TOS]	
 
;		
;--------------------------------------------------------------------------------------------
;the DICTIONARY
;--------------------------------------------------------------------------------------------
;********************************************************************************	
;emit ( char -- ) send a character to UART
;********************************************************************************	
;done in FORTH  24 bytes
;********************************************************************************				
Lemit:	head	4,'emit',0,0
;emit:	colon
;emit0:	dw	lit,UART_1_TX_CONTROL_REG,regat
;		dw	lit,16,pand
;		dw	zbr,emit0
;		dw	lit,UART_1_TX_INPUT_REG,regsto,exit
;********************************************************************************	
;emit done as machine code - 20 bytes
;********************************************************************************			
emit:	pops	W								;get the character
emit0:	mov a,reg[UART_1_TX_CONTROL_REG]		;see if the UART is ready
		and a, 16
		jz	emit0
		mov a, [W+1]		
		mov reg[UART_1_TX_INPUT_REG], a			;send it out
		next
;********************************************************************************					
;drop	( x -- ) drop TOS
;********************************************************************************	
Ldrop:	head	4,'drop',Lemit,0
drop:	add	sp,-2
		next
;********************************************************************************	
;dup	( x -- x x ) copy TOS
;********************************************************************************	
Ldup:	head	3,'dup',Ldrop,0
dup:	pops	W
		pushs	W
		pushW
;********************************************************************************			
;swap	( a b -- b a )
;********************************************************************************	
Lswop:	head	4,'swap',Ldup,0
swop:	pops	T0
		pops	W
		pushs	T0
		pushW
;********************************************************************************			
;over	( a b -- b a b )
;********************************************************************************	
Lover:	head	4,'over',Lswop,0
over:	pops	T0
		pops	W
		pushs	W
		pushs	T0
		pushW		
;********************************************************************************			
;1+		(a -- a+1 ) increment TOS
;********************************************************************************	
Lplone:	head	2,'1+',Lover,0
plone:	pops	W
		incr	W
		pushW
;********************************************************************************			
;1-		(a -- a-1) decrement TOS
;********************************************************************************	
Lmione:	head	2,'1-',Lplone,0
mione:	pops	W
		dec	[W+1]
		sbb [W],0
		pushW
;********************************************************************************			
;sp@	( -- sp) where is sp pointing
;********************************************************************************	
Lspat:	head	3,'sp@',Lmione,0
spat:	mov [W],0
		mov x,sp
		mov [W+1],x
		pushW
;********************************************************************************			
;rp@	( -- rp) where is rp pointing 
;********************************************************************************	
Lrpat:	head	3,'rp@',Lspat,0
rpat:	mov [W],0
		mov [W+1],[rp]
		pushW				
;********************************************************************************			
;sp!	( x -- ) point sp to x
;********************************************************************************	
Lspsto:	head	3,'sp!',Lrpat,0
spsto:	pops	W
		mov a, [W+1]
		swap	a, sp
		next
;********************************************************************************			
;rp!	( x -- ) point rp to x
;********************************************************************************	
Lrpsto:	head	3,'rp!',Lspsto,0
rpsto:	pops	W
		mov [W],0
		mov [rp],[W+1]
		next
;--------------------------------------------------------------------------------------------
;math
;-------------------------------------------------------------------------------------------
;+		( a b -- a+b) add top
Lplus:	head	1,'+',Lrpsto,0
plus:	pops	T0
		pops	W
		mov a, [T0+1]
		add	[W+1],a
		mov a,[T0]
		adc	[W],a
		pushW
;********************************************************************************			
;-		( a b -- b-a ) subtract top
;********************************************************************************	
Lminus:	head	1,'-',Lplus,0
minus:	pops	T0
		pops	W
		mov a, [T0+1]
		sub	[W+1],a
		mov a, [T0]
		sbb	[W],a
		pushW
;********************************************************************************			
; * 	( a b -- a*b ) 16 multiplication
;********************************************************************************	
Lmul:	head	1,'*',Lminus,0
mul:	pops	T0			;X
		pops	T1			;Y
		Multiply16_16_16	W,T0,T1
		pushW
;********************************************************************************	
;/mod	( a b -- b/a  b%a)
;********************************************************************************	
Ldivmod: head 4,'/mod',Lmul,0
 
divmod:	pops	T0
		pops	T1	
		call	div16
		pushs	W
		pushs	T1
		next
div16:          
		mov [W+0],00h			;clear Remainder
		mov [W+1],00h
		and F,fbh				;clear carry flag
		mov [T3],16		;load loop count to 16 for 16 bit division
d16u_1:         
		rlc [T1+1]				;rotate left through dividend and remainder
		rlc [T1+0]				
		rlc [W+1]				
		rlc [W+0]				
		mov [T2+0],[W+0]		;make backup of remainder
		mov [T2+1],[W+1]
		mov a,[W+1]			;subtract divisor from remainder
		sub a,[T0+1]
		mov [W+1],a
		mov a,[W+0]
		sbb a,[T0+0]
		mov [W+0],a
		jnc d16u_2					
		mov [W+1],[T2+1]		;if result is negative
		mov [W+0],[T2+0]		;restore remainder from backup
		and [T1+1],feh			;clear LSB of dividend
		jmp chkLcount16 
d16u_2:         
		or [T1+1],01h			;if result is positive set LSB of dividend
chkLcount16:
		dec [T3]			
		jnz d16u_1				;repeat till 16 bits are done
		ret		
;----------------------------------------------------------------------------------------------		
;memory ops
;----------------------------------------------------------------------------------------------
;@		( x -- ram[x]) get word at RAM[x]
Lat:	head	1,'@',Ldivmod,0
at:		pops	T0
		mov	x,[T0+1]
		mov	a,[x+0]
		mov [W], a
		mov a, [x+1]
		mov [W+1], a
		pushW
 
;c@		( x -- ram[x] ) get byte at RAM[x]
Lcat:	head	2,'c@',Lat,0
cat:	pops	T0
		mov x,[T0+1]
		mov [W],0
		mov a, [x]
		mov [W+1],a
		pushW
 
;rom@	( x -- rom[x]) get a word in rom
Lromat:	head	4,'rom@',Lcat,0
romat:	pops	T0
		mov a, [T0]
		mov x,[T0+1]
		romx
		mov [W],a
		mov a,[T0]
		inc x
		adc a,0
		romx
		mov [W+1],a
		pushW
 
;romc@	( x -- rom[x]) get a byte from rom
Lromcat:	head 5,'romc@',Lromat,0
romcat:	pops	T0
		mov a, [T0]
		mov x, [T0+1]
		romx
		mov [W+1],a
		mov [W],0
		pushW		
 
;!	( a b -- ) store word b in ram[a]				
Lsto:	head	1,'!',Lromcat,0
sto:	pops	T0
		pops	T1
		mov x, [T0+1]
		mov a, [T1]
		mov [x], a
		mov a, [T1+1]
		mov [x+1], a
		next
 
;c!	( a b -- ) store byte a in ram[b]
Lcsto:	head	2,'c!',Lsto,0
csto:	pops	T0
		pops	T1
		mov x, [T0+1]
		mov a, [T1+1]
		mov [x], a
		next		
 
;+!	( a b -- ) add a to ram[b]	(word)
Lpsto:	head	2,'+!',Lcsto,0
psto:	pops	T0
		pops	T1
		mov x, [T0+1]	;x points to lsb of destination
		mov a, [T1+1]	;a=lsb of number
		add [x+1], a
		mov a, [T1]		;a=msb of number
		adc [x], a
		next
 
;+c! ( a b -- ) add b to ram[a] (byte)		
Lpcsto: head	3,'+c!',Lpsto,0
pcsto:	pops	T0
		pops	T1
		mov x,[T0+1]
		mov a, [T1+1]
		add [x+0], a
		next
 
;----------------------------------------------------------------------------------------------
;system constants
;----------------------------------------------------------------------------------------------
 
LBASE:	head	4,'BASE',Lpcsto,0
BASE:	doCON
		dw	base
 
LHERE:	head	4,'HERE',LBASE,0
here:	doCON
		dw	HERE
 
LLAST:	head	4,'LAST',LHERE,0		
last:	doCON
		dw	LAST
Lcurrent: head 7,'CURRENT',LLAST,0
current: doCON
		dw	CURRENT
 
Lin:	head	2,'IN',Lcurrent,0
in:		doCON		
		dw	IN
 
LBLOC:	head	4,'BLOC',Lin,0
BLOC:	doCON
		dw	bloc
 
LLOC:	head	3,'LOC',LBLOC,0
LOC:	doCON
		dw	loc
;---------------------------------------------------------------------------------------------
;return stack ops
;---------------------------------------------------------------------------------------------
Ltor:	head	2,'>R',LLOC,0
tor:	pops	W
		pushr	W
		next
 
Lfromr:	head	2,'R>',Ltor,0				
fromr:	popr	W
		pushW
 
Lrat:	head	2,'R@',Lfromr,0
rat:	popr	W
		pushr	W
		pushW
 
;---------------------------------------------------------------------------------------------
;comparison
;---------------------------------------------------------------------------------------------
Leq:	head	1,'=',Lrat,0
eq:		pops	T0
		pops	W
		mov a, [W]
		cmp	a, [T0]
		jnz	false
		mov a, [W+1]
		cmp	a,[T0+1]
		jnz	false
negone:		
true:	mov a, -1
		push a
		push a
		next
zero:		
false:	mov a, 0
		push a
		push a
		next
;<	( a b -- t|f ) true if a<b false otherwise
Llt:	head	1,'<',Leq,0
lt:		pops	W
		pops	T0
		mov a, [T0]
		cmp	a, [W]
		jc	true
		jz	lt0
		jmp	false
lt0:	mov a,[T0+1]
		cmp	a,[W+1]
		jc	true
		jmp	false
 
Lexecute: head	7,'execute',Llt,0
execute:	ret		
;******************************************************************************************
;?key   ( -- T char | F ) If there is a character, return true and char
;******************************************************************************************	
Lqkey:	head    4,'?key',Lexecute,0
qkey:	mov A,  REG[UART_1_RX_CONTROL_REG]
		and	a, 8
		jnz get_char
		ljmp false
get_char:
		mov A, REG[UART_1_RX_BUFFER_REG]
		mov [W], 0
		mov [W+1],a
		pushs W
		ljmp true		
;******************************************************************************************	
;key    ( -- char )  get a character from the UART
;******************************************************************************************	
Lkey:	head	3,'key',Lqkey,0
key:	colon
key0:	dw	qkey,zbr,key0
		dw	exit
 
Lregsto:	head 4,'reg!',Lkey,0
regsto:	pops	W
		pops	T0
		cmp	[W],1
		jnz	regsto0
		m8c_SetBank1
regsto0:		
		mov x, [W+1]
		mov a, [T0+1]
		mov reg[x],a
		m8c_SetBank0
		next
 
Lregat:	head 4,'reg@',Lregsto,0
regat:	pops	W
		cmp	[W],1
		jnz	regat0
		m8c_SetBank1
regat0:	mov x,[W+1]
		mov a,reg[x]		
		m8c_SetBank0
		mov [W+1],a
		mov [W],0
		pushW
 
 
Lregor:	head	5,'regor',Lregat,0
regor:	pops	W
		pops	T0
		cmp	[W],1
		jnz	regor0
		m8c_SetBank1
regor0:	mov x, [W+1]
		mov a,reg[x]
		or a,[T0+1]
		mov reg[x],a
		m8c_SetBank0
		next
 
Lregand: head 6,'regand',Lregor,0
regand:	pops	W
		pops	T0
		cmp	[W],1
		jnz	regand0
		m8c_SetBank1
regand0:mov x, [W+1]
		mov a, reg[x]
		and a, [T0+1]
		mov reg[x],a
		m8c_SetBank0
		next
 
Lregxor: head 6,'regxor',Lregand,0
regxor:	pops	W
		pops	T0
		cmp	[W],1
		jnz	regxor0
		m8c_SetBank1
regxor0:mov x, [W+1]
		mov a,reg[x]
		xor a, [T0+1]
		mov reg[x],a
		m8c_SetBank0
		next
 
Land:	head	3,'and',Lregxor,0       ; b000 and word
pand:	pops	T0
		pops	T1
		mov a, [T0+1]
		and a, [T1+1]
		mov [W+1],a
		mov a, [T0]
		and a, [T1]
		mov [W],a
		pushW
 
Lor:	head	2,'or',Land,0            ; b000  or word
por:	pops	T0
		pops	T1
		mov a, [T0+1]
		or a, [T1+1]
		mov [W+1],a
		mov a, [T0]
		or a, [T1]
		mov [W],a
		pushW		
 
Lxor:	head	3,'xor',Lor,0       ; b000  xor word
pxor:	pops	T0
		pops	T1
		mov a, [T0+1]
		xor a, [T1+1]
		mov [W+1],a
		mov a, [T0]
		xor a, [T1]
		mov [W],a
		pushW				
 
Lnot:	head	3,'not',Lxor,0         ; b000  not word
not:	pops	W
		mov a, [W+1]
		cpl a
		mov [W+1], a
		mov a,[W]
		cpl	a
		mov [W],a
		pushW
 
Lnegate:head	6,'negate',Lnot,0
negate:	colon
		dw	not,plone,exit
 
Ltwostar:head	2,'2*',Lnegate,0
twostar:pops	W
		asl	[W+1]					;shift left ignoring carry (low byte)
		rlc	[W]						;shift left including carry	(high byte)
		pushW
 
Ltwodiv:head	2,'2/',Ltwostar,0
twodiv:	pops	W
		asr	[W]						;shift right ignoring carry (high byte)
		rrc	[W+1]					;shift right including carry (low byte)1]
		pushW						
 
 
Lshout:head	5,'shout',Ltwodiv,0      ; b001   shift out ?
shout:	pops	T0
		mov [W],0
		mov [W+1],0
		asr [T0]					;shift right ignoring carry (high byte)
		rrc [T0+1]					;shift right including carry (low byte)
		rlc [W+1]					;put the carry value into lsb
		pushs T0					;push the shifted source
		pushW						;push the lsb
 
 
 
Lzeq:	head	2,'0=',Lshout,0
zeq:	pops	W
		mov	a,[W]
		or	[W+1],a
		jz	true
		jmp	false
 
Lgt:	head	1,'>',Lzeq,0
gt:		colon
		dw	swop,lt,exit
 
Lneq:	head	2,'<>',Lgt,0
neq:	colon
		dw	eq,zeq,exit
 
Ldotq:	db	2,46,34      ; 2 chars '." '   dot-quote dot quote   b001
		dw	Lneq
		db	1
dotq:	colon
		dw	lit,xquote,tickw
dotq0:	dw	word,zbr,dotq1	
		dw	lit,TIB
		dw	lit,cnt,cat,dup,tick
dotq2:	dw	swop,dup,cat,tick
		dw	plone,swop,mione,dup
		dw	nzbr,dotq2
		dw	drop,drop,exit		
dotq1:	dw	accept,br,dotq0		
 
Lcount:	head	5,'count',Ldotq,0
count:	colon
		dw	dup,romcat,swop,plone,swop,exit
 
Ltype:	head	4,'type',Lcount,0
type:	colon
type_loop:
		dw	swop,dup,romcat,emit,plone
		dw	swop,mione,dup
		dw	zbr,type_done
		dw	br,type_loop
type_done:
		dw	drop,drop,exit		
 
Laccept:head	6,'accept',Ltype,0
accept:	colon
		dw	reset_in					;reset IN
		dw	lit,'>',emit				;prompt
accept0:dw	key							;get a char
		dw	dup, lit,28h, pxor
		dw	zbr,comment
accept1:dw	dup,emit						;print it
		dw	dup,lit,13,pxor				;is it a CR
		dw	zbr, EOL					;then handle it
		dw	dup,lit,8,pxor				;is it a BKSP
		dw	zbr,BKSP					;then handle it
		dw	in, cat, csto				;store in TIB
		dw	in, cat, plone,dup
		dw	lit, EOT,lt					;end of TIB?
		dw	zbr,TIB_FULL
		dw	in,csto
		dw	br,accept0					;do it again
comment:dw	drop
comment0:
		dw	key,lit,29h,pxor
		dw	nzbr, comment0
		dw	br,accept0		
TIB_FULL:
		dw	xquote
		db	11
		ds	'TIB FULL!'
		db	13,10
		dw	br,EOL0
EOL:	dw	lit,10,emit					;send a LF
		dw	drop
EOL0:	dw	zero						;replace CR with 0
		dw	in,cat,csto					;to mark end
		dw	reset_in,exit				;reset and exit						
BKSP:	dw	in,cat,lit,TIB,pxor
		dw	zbr,BKSP0
		dw	lit,20h,emit				;wipe out character
		dw	emit						;back up again
		dw	in,cat,mione				;back up IN
		dw	in,csto
		dw	br,accept0					;get another 
BKSP0:	dw	drop,lit,'>',emit
		dw	br,accept0		
reset_in: colon
		dw	lit,TIB,in,csto,exit
 
 
Llfa:	head	3,'lfa',Laccept,0
lfa:	colon
		dw	count,plus,exit
 
Lcfa:	head	3,'cfa',Llfa,0
cfa:	colon
		dw	lfa,lit,3,plus,exit
 
Llex:	head	3,'lex',Lcfa,0
lex:	colon
		dw	lfa,lit,2,plus,exit		
 
;word ( -- T|F )	moves next token to TIB.  Returns T if a word if a word is assembled, 
;					returns false if not.
word:	mov x, TIB
		mov [cnt], 0
skip:	mvi	a,[IN]
		jz	false
		cmp	a, 33
		jc	skip		;ignore white space		
scan:	mov	[x+0], a
		inc	[cnt]
		inc	x
		mvi	a,[IN]
		jz	word_done1
		cmp	a, 33
		jc	true
		jmp	scan
word_done1:
		dec	[IN]		;so that next time word fails
		jmp	true
 
swab:	pops	T0
		mov [W+1], [T0]
		mov [W],[T0+1]
		pushW
 
 
d2a:	colon
		dw	dup,lit,9,gt
		dw	zbr,d2a0
		dw	lit,7,plus
d2a0:	dw	lit,30h,plus,emit,exit		
 
Ldot:	head	1,'.',Llex,0		
dot:	colon
		dw	zero,swop
dot0:	dw	BASE,cat,divmod,swop,tor
		dw	swop,plone,swop,dup,nzbr,dot0
		dw	drop
dot1:	dw	fromr,d2a,mione,dup,nzbr,dot1
		dw	drop,exit		
 
Lspc:	head 3,'spc',Ldot,0
spc:	colon
		dw	lit, 20h, emit, exit
 
Lcrlf:	head	4,'crlf',Lspc,0
crlf:	colon
		dw	lit,13,emit
		dw	lit,10,emit,exit
 
Lwords:	head	5,'words',Lcrlf,0
words:	colon
		dw	last, at	
words_loop:
		dw	dup,count,type,lit,20h,emit
		dw	lfa,romat,dup
		dw	zbr,words_done
		dw	br,words_loop
words_done:
		dw	drop,crlf,exit			
 
;match	( nfa -- t|f ) see if TOS and word match
match:	mov	[T0], cnt
		mov	[W],[cnt]
		inc	[W]
		pop	x
		pop	a
match_loop:
		push	a
		romx
		mov [W+1], a
		mvi	a, [T0]
		cmp	a,[W+1]
		jnz	no_match
		pop	a
		inc	x
		adc	a, 0
		dec	[W]
		jz	true
		jmp	match_loop
no_match:
		pop	a
		jmp	false
 
; find ( -- [nfa t]|f ) see if WORD is in the dictionary. If it is,
;						return true and nfa, else, return false.
find:	colon
		dw	last, at
find_loop:
		dw	dup, match
		dw	zbr, find_next
		dw	true,exit				;leaves nfa and true					
find_next:
		dw	lfa,romat,dup
		dw	zbr,not_found
		dw	br,find_loop
not_found:
		dw	drop,false,exit
 
;>dig try to convert WORD to a number returns true and value or false
todig:	colon
		dw	lit,cnt,cat,lit,TIB
		dw	zero,tor
todig_loop:
		dw	dup,cat,qdig
		dw	zbr,not_dig
		dw	fromr,BASE,	cat,mul,plus,tor
		dw	plone,swop,mione,dup
		dw	zbr,todig_done
		dw	swop,br,todig_loop
todig_done:
		dw	drop,drop,fromr,true,exit
not_dig:
		dw	drop,drop,drop,fromr,drop,false,exit				
 
 
;( char -- [t n]|[f char] )
qdig:	pops	W
		mov [W],0
		sub	[W+1],48
		jc	not_dig0
		cmp [W+1],10
		jc	is_dig
		sub	[W+1],7
		jc	is_dig
		cmp	[W+1],16
		jc is_dig
		sub	[W+1],32
		jc	not_dig0
		cmp	[W+1],16
		jc	is_dig
not_dig0:
		pushs	W	
		jmp	false		
is_dig:	mov a, [W+1]
		cmp	a, [base]
		jc	digit
		jmp	not_dig0
digit:	pushs	W
		jmp	true
;----------------------------------------------------------------------------------------------------
;compiler
;----------------------------------------------------------------------------------------------------
 
Lblkat:	head	4,'blk@',Lwords,0
blkat:	pops	W	
		lcall	read_blk
		next
 
 
 
Lblksto: head	4,'blk!',Lblkat,0
blksto:	pops	W
		lcall	blk_write
		next
 
 
; >bloc ( addr -- loc bloc ) 	convert an address to a block and location for
;						FLASH ROM access
Ltobloc: head 5,'>bloc',Lblksto,0
tobloc:	colon
		dw	lit,40h,divmod,exit
 
; >addr ( bloc loc -- addr )	convert a bloc/loc to an address		
Ltoaddr: head 5,'>addr',Ltobloc,0
toaddr:	colon
		dw	lit,40h,mul,plus,exit
 
;' ( char -- ) 	tick - write a byte to FLASH.  Writes to FLASH BUFFER (RAM 0-3f).  When
;					buffer is full, writes to FLASH and resets the buffer to bloc+1.
Ltick:	db	1,96
		dw	Ltoaddr
		db	0
tick:	colon
		dw	LOC,cat,csto	
		dw	LOC,cat,plone		
		dw	dup,lit,40h,pxor,zbr,reload		
		dw	LOC,csto
		dw	exit
reload:	dw	drop,BLOC,cat,blksto
		dw	BLOC,cat,plone,BLOC,csto
		dw	zero,LOC,csto		
		dw	exit
 
tickw:	colon
		dw	dup,swab,tick,tick,exit
 
new_here: colon
		dw	LOC,cat,BLOC,cat,toaddr,here,sto
		dw	exit
 
; create 
Lcreate:head	6,'create',Ltick,0
create:	colon
		dw	here,at,tobloc,BLOC,csto,LOC,csto
		dw	BLOC,cat,blkat
create1:dw	word,zbr,create2
		dw	lit,cnt,cat,plone
		dw	lit,cnt
create_loop:								;compile name
		dw	dup,cat,tick
		dw	plone,swop,mione,dup
		dw	zbr,created
		dw	swop,br,create_loop
created:dw	drop,drop,last,at,tickw			;compile lex
		dw	zero,tick
		dw	BLOC,cat,blksto									;write it
		dw	here,at,last,sto								;here->last 
		dw	new_here										;bloc/loc->here
		dw	exit
create2:dw	accept,br,create1
 
; constant
Lconstant: head	8,'constant',Lcreate,0
constant:
		colon
		dw	create
		dw	lit,7ch,tick		;compile lcall
		dw	lit,_doCON,tickw	;compile _doCON
		dw	tickw				;compile TOS
		dw	BLOC,cat,blksto		;write it
		dw	new_here
		dw	exit
 
; table 
Ltable:	head	5,'table',Lconstant,0
tabl:	colon
		dw	create
		dw	lit,7ch,tick
		dw	lit,_next,tickw			;compile doTABLE
table0:	dw	word,zbr,table1		
		dw	todig,zbr,table_err
		dw	tick,br,table0
table_err:
		dw	lit,TIB,cat,lit,22h,pxor,zbr,table_done
		dw	br, compile_err
table_done:
		dw	BLOC,cat,blksto		;write it
		dw	new_here
		dw	exit
table1:	dw	accept,br,table0
 
 
 
; colon :    head of compile
Lcompile:	head	1,':',Ltable,0
compile:
		colon
		dw	create
		dw	lit,7ch,tick
		dw	lit,_colon,tickw		;compile LCALL _colon
compile_loop:
		dw	word,zbr,compile0
		dw	find,zbr,compile_num
		dw	dup,lex,romcat,zbr,compile_word
		dw	cfa,execute,br,compile_loop
compile_word:
		dw	cfa,tickw,br,compile_loop
compile_num:
		dw	todig,zbr,compile_err
		dw	lit,lit,tickw,tickw
		dw	br,compile_loop
compile_err:
		dw	print
		dw	xquote
		db	13
		ds	' not found.'
		db	13,10
		dw	last,at,here,sto
		dw	last, at,lfa,romat
		dw	last,sto,save
		dw	abort						
compile0:
		dw	accept,br,compile_loop		
 
immed:	equ	1
Lsemi:	db	1,59
		dw	Lcompile
		db	immed
semi:	colon
		dw	lit,exit,tickw
		dw	BLOC,cat,blksto
		dw	new_here
		dw	quit
 
Lforget:	head	6,'forget',Lsemi,0
forget:		colon
forget1:dw	word,zbr,forget0
		dw	find,zbr,forget2
		dw	dup, here,sto
		dw	lfa,romat,last,sto,save,exit
forget2:dw	xquote
		db	24
		ds	'not in the dictionary.'
		db	13,10
		dw	quit		
forget0:dw	accept,br,forget1
 
;startup   <my_word><startup> will make FORTH start at <my_word> rather than <cold>
Lstartup:	head	7,'startup',Lforget,0
startup:	colon
startup1:
		dw	word,zbr,startup0
		dw	find,zbr,forget2
		dw	cfa,current,sto
		dw	save,exit		
startup0:
		dw	accept,br,startup1		
 
Lbootat:	head	5,'boot@',Lstartup,0
bootat:	colon
		dw	lit,ffh,blkat,exit		
 
Lbootsto:	head	5,'boot!',Lbootat,0		
bootsto: colon
		dw	lit,ffh,blksto,exit		
 
Lsave:	head	4,'save',Lbootsto,0
save:	colon
		dw	bootat
		dw	last,at,lit,vlast,sto
		dw	here,at,lit,vhere,sto
		dw	current,at,lit,vcurr,sto
		dw	bootsto
		dw	exit
 
 
;-------------------------------------------------------------------------------------------------
;interrrupt words
;-------------------------------------------------------------------------------------------------
 
; GIE       enable general interrupt	
Lgie:	head	3,'GIE',Lsave,0
gie:	M8C_EnableGInt
		next		
; GID    disable general interrupt		
Lgid:	head	3,'GID',Lgie,0
gid:	M8C_DisableGInt
		next
 
; sar1  ( -- n )  get analog value connected to SAR1 ADC input pin
Lsar1:	head	4,'sar1',Lgid,0
sar1:	mov 	a, 3
		lcall	sar1_SetPower
		lcall	sar1_GetSample
		mov		x,0
		push	x
		add		a, 20h
		push 	a
		lcall	sar1_Stop
		next	
 
; sar2  ( -- n )  get analog value connected to SAR2 ADC input pin
Lsar2:	head	4,'sar2',Lsar1,0
sar2:	mov	a,3
		Lcall	sar2_SetPower
		lcall	sar2_GetSample
		mov		x,0
		push	x
		add		a, 20h
		push	a
		lcall	sar2_Stop
		next
 
; sar3  ( -- n )  get analog value connected to SAR3 ADC input pin
Lsar3:	head	4,'sar3',Lsar2,0
sar3:	mov		a,3
		Lcall 	amp_Start
		mov 	a,3
		lcall	sar3_SetPower
		lcall	sar3_GetSample
		mov		x,0
		push	x
		add		a, 20h
		push	a
		lcall	sar3_Stop
		Lcall	amp_Stop		
		next
 
; temp  
Ltemp:	head 	4,'temp',Lsar3,0	
temp:	mov 	reg[INT_VC],0
		M8C_EnableGInt
		lcall	FlashTemp_1_Start
temp_loop:
		lcall	FlashTemp_1_fIsData
		cmp		a,0
		jz		temp_loop
		lcall	FlashTemp_1_cGetData
		lcall	FlashTemp_1_Stop
		mov 	[W+1], a
		mov 	[W], 0
		M8C_DisableGInt
		pushW			
;--------------------------------------------------------------------------------------------------		
;control structures
;--------------------------------------------------------------------------------------------------
mark:	colon
		dw	LOC,cat,BLOC,cat,toaddr,exit
 
unmark:	colon
		dw	tickw,exit		
 
; begin
Lbegin:	head	5,'begin',Ltemp,immed
begin:	colon
		dw	mark,exit		
; again
Lagain:	head	5,'again',Lbegin,immed
again:	colon
		dw	lit,br,tickw,unmark,exit
; until		
Luntil:	head	5,'until',Lagain,immed
until:	colon
		dw	lit,nzbr,tickw
		dw	unmark
		dw	exit						
 
; if
Lif:	head	2,'if',Luntil,immed
pif:	colon
		dw	lit,zbr,tickw
		dw	mark,zero,tickw,exit
; (addr addr -- ) 
resolve:	colon
		dw	BLOC,cat,blksto				;save current blk
		dw	BLOC,cat,tor,LOC,cat,tor	;save current BLOC ptr
		dw	tobloc						;convert mark to BLOC
		dw	BLOC,csto,LOC,csto			;put in BLOC ptr
		dw	BLOC,cat,blkat				;get code to be resolved
		dw	fromr,fromr,toaddr			;convert jmp address
		dw	dup,tickw					;compile it
		dw	BLOC,cat,blksto				;save code
		dw	tobloc						;convert to BLOC
		dw	BLOC,csto,LOC,csto			;restore BLOC ptr
		dw	BLOC,cat,blkat				;restore blk
		dw	exit
 
; endif
Lthen:	head	5,'endif',Lif,immed
then:	colon
		dw	resolve,exit			
 
; else		
Lelse:	head	4,'else',Lthen,immed
pelse:	colon
		dw	lit,br,tickw
		dw	mark
		dw	zero,tickw
		dw	tor,resolve,fromr,exit			
 
Ldo:	head	2,'do',Lelse,immed
do:		colon
		dw	mark,lit,tor,tickw,exit
 
;break forces premature end of do by replaceing the return stack with 1		
Lbreak:	head	5,'break',Ldo,0
break:	colon
		dw	fromr, fromr, drop, lit, 1, tor,tor
		dw	exit	
 
Lloop:	head	4,'loop',Lbreak,immed
loop:	colon
		dw	lit,fromr,tickw
		dw	lit,mione,tickw
		dw	lit,dup,tickw
		dw	lit,nzbr,tickw
		dw	unmark			
		dw	lit,drop,tickw
		dw	exit
 
Lwhile:	head	5,'while',Lloop,immed
while:	colon
		dw	pif,exit
 
Lwend:	head	4,'wend',Lwhile,immed
wend:	colon
		dw	swop,again,then,exit				
;--------------------------------------------------------------------------------------------------
;i/o words
;--------------------------------------------------------------------------------------------------
 
seperate:
		rlc	[W]
		rlc	[W]
		mov a,1
seperate0:
		or	[W+1],0
		jz	seperate1
		rlc	a
		dec	[W+1]
		jmp	seperate0
seperate1:
		mov [W+1],a
		mov x,[W]
		ret				
 
 
Linput: head	5,'input',Lwend,0
input:	pops	W
		call	seperate
		mov a, [W+1]
		cpl a
		mov [W], a
		M8C_SetBank1
		mov a, reg[x]
		and a, [W]
		mov reg[x], a
		mov a, reg[x+1]
		or a, [W+1]
		mov reg[x+1], a
		M8C_SetBank0
		next
 
Lstrong: head	6, 'strong',Linput,0
strong:	pops	W
		call	seperate
		mov a, [W+1]
		cpl	a
		mov [W], a
		M8C_SetBank1
		mov a, reg[x]
		or a, [W+1]
		mov reg[x], a
		mov a, reg[x+1]
		and a, [W]
		mov reg[x+1], a
		M8C_SetBank0
		next
 
Lpullup:	head 6,'pullup',Lstrong,0
pullup:	pops	W
		call	seperate
		M8C_SetBank1
		mov a, reg[x]
		or a, [W+1]
		mov reg[x], a
		mov a, reg[x+1]
		or a, [W+1]
		mov reg[x+1], a
		M8C_SetBank0
		next
 
Lpulldown: head 8,'pulldown',Lpullup,0
pulldown: pops	W
		call seperate
		mov a, [W+1]
		cpl a
		mov [W],a
		M8C_SetBank1		
		mov a, reg[x]
		and a, [W]
		mov reg[x], a
		mov a, reg[x+1]
		and a, [W]
		mov reg[x+1],a
		M8C_SetBank0
		next
 
Lon:	head	2,'on',Lpulldown,0
pon:	pops	W
		call	seperate
		mov a,reg[x]
		or a,[W+1]
		mov reg[x], a
		next
 
 
Loff:	head	3,'off',Lon,0		
poff:	pops	W
		call	seperate
		mov a,[W+1]
		cpl	a
		mov [W+1],a
		mov a,reg[x]
		and a, [W+1]
		mov reg[x],a
		next
 
Ltoggle: head	6,'toggle',Loff,0		
toggle:	pops	W
		call	seperate
		mov a, reg[x]
		xor a, [W+1]
		mov reg[x],a
		next		
 
Linp:	head	3,'inp',Ltoggle,0				
inp:	pops	W
		call	seperate
		mov [W],0
		mov a,reg[x]
		and a, [W+1]
		jz	inp0
		mov [W+1],1
		pushW
inp0:	mov [W+1],0
		pushW	
 
save_mode:	
		mov a, reg[x]
		mov [T0], a
		mov a, reg[x+1]
		mov [T0+1], a						
		ret
 
restore_mode:
		M8C_SetBank1
		mov a, [T0]
		mov reg[x],a
		mov a, [T0+1]
		mov reg[x+1],a			;port mode restored
		M8C_SetBank0
		ret
 
 
;pulsout ( length pin -- )		
Lpulsout: head	7,'pulsout',Linp,0
pulsout:pops	W
		call	seperate
		cpl a
		mov [W],a				;W+1=pin, W=~pin,
		M8C_SetBank1
		call save_mode
		and a, [W]				
		mov reg[X+1], a			;DM1=0
		mov a, reg[x]
		or a, [W+1]
		mov reg[x], a			;DM0=1 pin is strong
		M8C_SetBank0
		pops	T1				;get pulse length
		mov a, reg[x]			;
		xor a, [W+1]			;
		mov reg[x], a			;pin is opposite
pulsout_loop:
		lcall	OneWireSW_1_Delay50u
		dec		[T1+1]
		sbb		[T1], 0
		jnc		pulsout_loop
		mov a, reg[x]			
		xor a, [W+1]
		mov reg[x], a			;pin is opposite
		call restore_mode
		next
 
;pulsin				
Lpulsin: head	6,'pulsin',Lpulsout,0
pulsin:	pops	W
		call	seperate
		cpl	a
		mov [W], a			;x=port, W=~pin, W+1=pin
		mov [T1],0
		mov [T1+1],0		;initialize counter
		M8C_SetBank1
		call save_mode
		and	a, [W]
		mov reg[x+1],a		;DM1=0
		mov a, reg[x]
		and a, [W]			
		mov reg[x],a		;dm0=0
		M8C_SetBank0
		pops	T2			
		mov a, [T2+1]
		and a, [W+1]
		mov [T2],a			;T2=state
pulsin_hold:		
		mov a, reg[x]		;sample pin
		and a, [W+1]
		cmp a, [T2]
		jnz	pulsin0			;if state <> start measuring
		inc	[T1+1]
		adc	[T1],0
		jnc	pulsin_hold		;continue sampling until timeout
		jmp	pulsin_fail		;timeout, return 0
pulsin0:mov [T1],0
		mov [T1+1],0
pulsin_edge:
		mov a,reg[x]
		and a, [W+1]		;sample pin
		cmp	a, [W+1]
		jnz	get_pulse		;if state changes, start measuring
		inc	[T1+1]
		adc	[T1],0
		jnc	pulsin_edge		;if no time out, sample again
		jmp	pulsin_fail		;timeout, return 0
get_pulse:
;		lcall	OneWireSW_1_Delay50u
		mov 	a,reg[x]
		and		a, [W+1]		;sample pin
		cmp		a, [W+1]		;
		jnz		pulsin_done		;when state changes, you're done
		inc		[T1+1]
		adc		[T1],0
		jnc		get_pulse		;continue until pulsedone or timeout
pulsin_fail:
		call	restore_mode
		ljmp	false		
pulsin_done:
		call	restore_mode
		pushs	T1		
		next
 
;delay	(x -- ) delay for length x * 50 usec
Ldelay:	head	5,'delay',Lpulsin,0
delay:	pops	W
delay_loop:
		lcall	OneWireSW_1_Delay50u
		dec		[W+1]
		sbb		[W],0
		jnc		delay_loop
		next		
 
;ow_rst		one wire reset
Lowrst:	head	6, 'OW_rst',Ldelay,0
owrst:	lcall	OneWireSW_1_Reset
		mov		[W+1],a
		mov		[W],0
		pushW
 
;OWwr:    one wire write
Lowwr:	head 5, 'OW_wr',Lowrst,0
owwr:	pops	W
		mov		a, [W+1]
		lcall	OneWireSW_1_WriteByte
		next
 
;OWwrs:	one wire write strong
Lowwrs:	head 6, 'OW_wrs',Lowwr, 0
owwrs:	pops	W
		mov		a, [W+1]
		lcall	OneWireSW_1_WriteByteStrong
		next
 
;OWrd:          one wire read byte
Lowrd:	head 5, 'OW_rd', Lowwrs, 0
owrd:	lcall	OneWireSW_1_ReadByte
		mov		[W+1], a
		mov		[W], 0
		pushW		
;--------------------------------------------------------------------------------------------------
print:	colon
		dw	lit,cnt,cat
		dw	lit,TIB
print_loop:
		dw	dup,cat,emit,plone
		dw	swop,mione,dup
		dw	zbr,printq
		dw	swop,br,print_loop
printq:	dw	drop,drop
		dw	exit
 
interpret:
		colon
interpret_loop:		
		dw	word, zbr, interpret0
		dw	find,zbr,qnum
		dw	cfa,execute,br,interpret_loop
qnum:	dw	todig
		dw	zbr,qtok
		dw	br,interpret_loop
qtok:	dw	print
		dw	lit,'?',emit,crlf	
interpret0:
		dw	exit		
 
;hex    change base to 16D
Lhex:	head	3,'hex',Lowrd,0
hex:	colon
		dw	lit,10h,BASE,csto,exit
 
;hex    change base to 10D		
Ldec:	head	7,'decimal',Lhex,0
decimal: colon
		dw	lit,0ah,BASE,csto,exit
 
;hex    change base to 2D
Lbinary: head	6,'binary',Ldec,0
binary:	colon
		dw	lit,2,BASE,csto,exit
 
 
; quit
Lquit:	head	4,'quit',Lbinary,0
quit:	colon
		dw	lit,rp0,rpsto	
quit_loop:
		dw	spat,dot,rpat,dot
		dw	accept,interpret
		dw	xquote
		db	4
		ds	'ok'
		db	13,10
		dw	br,quit_loop
 
; abort
Labort:	head	5,'abort',Lquit,0				
abort:	colon
		dw	lit,sp0,spsto
		dw	quit
 
; default
Ldefault:	head 7,'default',Labort,0		
default:	colon
		dw	lit,d_top,last,sto
		dw	lit,new_code,here,sto
		dw	hex
		dw	lit,cold,current,sto
		dw	exit
 
; init
Linit:	head	4,'init',Ldefault,0		
init:	colon
		dw	lit,Vlast,romat,last,sto
		dw	lit,Vhere,romat,here,sto
		dw	lit,Vcurrent,romat,current,sto
		dw	hex
		dw	exit			
d_top:						
 
; cold
Lcold:	head	4,'cold',Linit,0				
cold:	colon
		dw	lit,12,emit
		dw	lit,201h,inp
;		dw	lit,101h,inp		;use pin 1.1 for 27143    b001   look for different pins for 29466
		dw	nzbr,saftey
		dw	init,br,cold0
saftey:	dw	default	
		dw	lit,40h,emit	
cold0:	dw	xquote
		db	endend - $   ;  end minus here  b001   this is length of string
		ds	'PSoC FORTH v2.01 beta001 b001  updated 20070821' ; b001
endend:		db	13,10    ; b001
		dw	abort
 
		org	2000h
new_code:
 
 
 
	org	3fc0h
Vcurrent:	dw	cold		;3fc0
Vlast:		dw	d_top		;3fc2
Vhere:		dw	new_code	;3fc4
Vbase:		db	10h,0,0,0	;3fc6

;    kernal 16 bit forth for PSoC 27443 - 28 pin device
;    copyright 2003, Christopher W. Burns
;    This program is free software; you can redistribute it and/or modify
;    it under the terms of the GNU General Public License as published by
;    the Free Software Foundation; either version 2 of the License, or
;    (at your option) any later version.
 
;    This program is distributed in the hope that it will be useful,
;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;    GNU General Public License for more details.
 
;    You should have received a copy of the GNU General Public License
;    along with this program; if not, write to the Free Software
;    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
; Modified 20070821   WFT Electronics   wftElectronics.com
; b001   DHD ( Bill Goodrich ) and AGSC   Denver, CO
; same licensing as above
; questions  ?????
;  what is rp ?   return pointer ?
 
;memory map
	include	"m8c.inc"
	include	"unsignedmath.inc"
	include "uart_1.inc"     ; install UART   can we install another UART ? b001
;	include "counter8_1.inc"
	include "sar1.asm"
	include "sar2.asm"
	include "sar3.asm"
	include "amp.asm"
	include "flashtemp_1.asm"
	include "flashtemp_1int.asm"
	include	"onewiresw_1.asm"
;__________________________________________________________________________________
;00|                                                                               |
;10|                                                                               |
;20|		FLASH WRITE BUFFER                                                     |
;30|_______________________________________________________________________________|
;40|		PARAMETER STACK                                                        |
;50|                                                                               |
;60|                                                                               |
;70|                                                                               |
;80|_________RETURN STACK__________________________________________________________|
;90|                                                                               |
;A0|                                                                               |
;B0|_______________________________________________________________________________|
;C0|_cnt|TEXT INPUT BUFFER                                                         |
;D0|_______________________________________________________________________________|
;E0|___IP____|____W____|___HERE__|___LAST__|_CURRENT_|bloc|loc_|_rp_|base|_IN_|____|
;F0|_________|_________|_________|_________|___T0____|____T1___|___T2____|___T3____|
IP:		equ		e0h
W:		equ		e2h
HERE:	equ		e4h
LAST:	equ		e6h
CURRENT:equ		e8h
bloc:	equ		eah
loc:	equ		ebh
rp:		equ		ech
base:	equ		edh
IN:		equ		eeh
 
T0:		equ		f8H
T1:		equ		fah
T2:		equ		fch
T3:		equ		feh
 
sp0:	equ		40h
rp0:	equ		90h
 
cnt:	equ		c0h
TIB:	equ		c1h
EOT:	equ		e0h
 
;boot block structure mirrored in RAM
vcurr:		equ	0
vlast:		equ	2
vhere:		equ	4
vbase:		equ	6
 
;--------------------------------------------------------------------------------------
;macros
;--------------------------------------------------------------------------------------
macro	next
		ljmp	_next
endm
 
macro	pushW
		ljmp	_pushW
endm
 
macro	incr
		inc	[@0+1]
		adc	[@0],0
endm		
 
macro	colon
		lcall	_colon
endm
 
macro	doCon
		lcall	_doCON
endm		
 
macro	fetch
		mov	a, [IP]
		mov	x, [IP+1]
		romx
		mov	[@0], a
		incr	IP
endm		
 
macro	pushs
		mov a,[@0]
		push a
		mov a, [@0+1]
		push a
endm
;********************************************************************************	
;pop the stack into a word register
;********************************************************************************	
macro	pops		
		pop	a				;1
		mov [@0+1], a		;2
		pop	a				;1
		mov	[@0], a			;2
endm
;********************************************************************************	
 
macro	pushr
		mov x, [rp]
		dec x
		mov a, [@0]
		mov [x], a
		dec x
		mov a, [@0+1]
		mov [x], a
		mov [rp], x
endm
 
macro	popr
		mvi	a,[rp]
		mov	[@0+1], a
		mvi	a,[rp]
		mov [@0], a
endm
 
;	header structure
;	<len><"name"><LINK address><flags>|CODE FIELD|
macro	head
		db	@0
		ds	@1
		dw	@2
		db	@3
endm		
;-------------------------------------------------------------------------------------------------		
	area	kernal16(rom,abs)
 
	org		540h
send:	M8C_DisableGInt
		push a
send0:	mov A,  REG[UART_1_TX_CONTROL_REG]
		and	a,  16
		jz	send0
		pop	a
		mov REG[UART_1_TX_INPUT_REG], a
		ret	
read_blk:	
		mov [0f8h],3ah  ;should be 3ah
		mov X,sp
		mov a,X
		add a,3		
		mov [0f9h],a    ;sp+3
		mov [0fah],[W+1]   ;block id
		mov [0fbh], 0  ;buffer pointer
		mov [0fch],15   ;clock
		mov [fdh], 0
		mov [feh], 0
		mov [ffh], 0
		mov a,01
		SSC				;erase block
		nop
		nop
		nop
		ret	
blk_write:	
		mov [0f8h],3ah  ;should be 3ah
		mov X,sp
		mov a,X
		add a,3		
		mov [0f9h],a    ;sp+3
		mov [0fah],[W+1]   ;block id
		mov [0fbh], 0  ;buffer pointer
		mov [0fch],15   ;clock
		mov [fdh], 0
		mov [feh], 0
		mov [ffh], 0
		mov a,03
		SSC				;erase block
		nop
		nop
		nop
 
		mov [0f8h],3ah       ;should be 3ah
		mov X,sp
		mov a,X
		add a,3		
		mov [0f9h],a     	 ;sp+3
		mov [0fah],[W+1]   		 ;block id
		mov [0fbh],0		 ;buffer pointer
		mov [0fch],15   	 ;clock
		mov [fdh], 0
		mov [feh], 0
		mov [ffh], 0	
		mov a,02
		SSC				;write block
		nop	
		nop
		nop
		ret		
 
start::	mov		a,sp0
		swap	a,sp						;initialize the stack
		mov	    [rp],rp0					;initialize the return stack
		lcall	OneWireSW_1_Start			;initialize one wire protocall
;********************************************************************************		
;initialize the UART
;********************************************************************************
;		or   reg[Counter8_1_CONTROL_REG],1
    	or   REG[UART_1_TX_CONTROL_REG], 1
    	or   REG[UART_1_RX_CONTROL_REG], 1
;********************************************************************************    	
	   	mov	[IP],>FORTH
	   	mov [IP+1],<FORTH					;point to the main FORTH loop
	   	mov	a, reg[8]						;check saftey is set 
;		mov a, reg[12]						;use pin 1.1 for 27143
	   	and a, 2
	   	jz	user
;********************************************************************************
;this is the default start
;********************************************************************************	   	
		mov [CURRENT],>cold					
		mov [CURRENT+1],<cold				;set current to "cold"
		next								;start FORTH
;********************************************************************************
; this is the user's start up
;********************************************************************************
user:  	mov a, >Vcurrent					
		mov x, <Vcurrent					;User's startup
		romx
		mov	[CURRENT],a						;
		mov a, >Vcurrent
		inc	x
		romx
		mov	[CURRENT+1],a
		next
;********************************************************************************
;MAIN FORTH LOOP
;fetch the vector from "current" and execute.  When done, continous loop.
;********************************************************************************		
FORTH:	dw	current,at,execute,br,FORTH		
;-------------------------------------------------------------------------------------------
;headerless words
;-------------------------------------------------------------------------------------------
;colon	IP->rstack
;		pstack->IP
;		next
;get to colon by LCALL _colon the return address pushed by LCALL is the new IP
_colon:	pushr	IP
		pops	IP
		next
;********************************************************************************		
;exit  rstack->IP
;********************************************************************************
exit:	popr	IP					;pop the return address into the instruction pointer
		next
;********************************************************************************
;br     Branch to an inline address
;********************************************************************************		
br:		fetch	W
		fetch	W+1
		mov	[IP],[W]
		mov	[IP+1],[W+1]
		next
;********************************************************************************
;zbr	Branch to an inline address if TOS is 0, otherwise skip		
;********************************************************************************
zbr:	pops	W
		mov a, [W]
		or a,[W+1]
		jz	br
pass:	add	[IP+1],2
		adc	[IP],0
		next
;********************************************************************************
;nzbr	Branch to an inline address if TOS <> 0, other wise skip
;********************************************************************************		
nzbr:	pops	W
		mov	a,[W]
		or a,[W+1]
		jnz	br
		jmp	pass
;********************************************************************************
;lit	Pushes an inline word onto the parameter stack
;********************************************************************************		
lit:	fetch W
		fetch W+1
		pushW
;********************************************************************************		
;doCON get here by LCALL _doCON  - pushs address of constant on the stack
; and then fetches constant to the stack
;********************************************************************************
_doCON:	pop	x
		pop a
		push	a
		romx
		mov [W], a
		pop	a
		inc	x
		adc	a,0
		romx
		mov [W+1],a
		pushW
;********************************************************************************		
;xquote send an counted string to the UART
;********************************************************************************
xquote:	fetch	W			;length in W
xquote_loop:
		fetch	W+1			;char->W+1
		mov a, [W+1]
		call	send		;send it out
		dec	[W]				;decrease count
		jnz xquote_loop		;if it's not zero do it again
		next				;IP points to next token
;********************************************************************************
;doTable - push the address of the next word on the stack
;********************************************************************************
macro	doTABLE
	lcall	_next
endm		
 
 
 
;-----------------------------------------------------------------------------------------------
;inner interpreter - 
;						-check for an interrupt
;						ROM[IP]->W
;						IP+2->IP
;						W->stack
;						jmp(TOS)
;	
;********************************************************************************	
_pushW:	pushs	W						;push W register
_next:	fetch	W
		fetch	W+1						;ROM[IP]->W IP+2
		pushs	W						;W-> stack
		ret								;jmp[TOS]	
 
;		
;--------------------------------------------------------------------------------------------
;the DICTIONARY
;--------------------------------------------------------------------------------------------
;********************************************************************************	
;emit ( char -- ) send a character to UART
;********************************************************************************	
;done in FORTH  24 bytes
;********************************************************************************				
Lemit:	head	4,'emit',0,0
;emit:	colon
;emit0:	dw	lit,UART_1_TX_CONTROL_REG,regat
;		dw	lit,16,pand
;		dw	zbr,emit0
;		dw	lit,UART_1_TX_INPUT_REG,regsto,exit
;********************************************************************************	
;emit done as machine code - 20 bytes
;********************************************************************************			
emit:	pops	W								;get the character
emit0:	mov a,reg[UART_1_TX_CONTROL_REG]		;see if the UART is ready
		and a, 16
		jz	emit0
		mov a, [W+1]		
		mov reg[UART_1_TX_INPUT_REG], a			;send it out
		next
;********************************************************************************					
;w drop	( x -- ) drop TOS
;********************************************************************************	
Ldrop:	head	4,'drop',Lemit,0
drop:	add	sp,-2
		next
;********************************************************************************	
;w dup	( x -- x x ) copy TOS
;********************************************************************************	
Ldup:	head	3,'dup',Ldrop,0
dup:	pops	W
		pushs	W
		pushW
;********************************************************************************			
;w swap	( a b -- b a )
;********************************************************************************	
Lswop:	head	4,'swap',Ldup,0
swop:	pops	T0
		pops	W
		pushs	T0
		pushW
;********************************************************************************			
;w over	( a b -- b a b )
;********************************************************************************	
Lover:	head	4,'over',Lswop,0
over:	pops	T0
		pops	W
		pushs	W
		pushs	T0
		pushW		
;********************************************************************************			
;w 1+		(a -- a+1 ) increment TOS
;********************************************************************************	
Lplone:	head	2,'1+',Lover,0
plone:	pops	W
		incr	W
		pushW
;********************************************************************************			
;w 1-		(a -- a-1) decrement TOS
;********************************************************************************	
Lmione:	head	2,'1-',Lplone,0
mione:	pops	W
		dec	[W+1]
		sbb [W],0
		pushW
;********************************************************************************			
;sp@	( -- sp) where is sp pointing
;********************************************************************************	
Lspat:	head	3,'sp@',Lmione,0
spat:	mov [W],0
		mov x,sp
		mov [W+1],x
		pushW
;********************************************************************************			
;rp@	( -- rp) where is rp pointing 
;********************************************************************************	
Lrpat:	head	3,'rp@',Lspat,0
rpat:	mov [W],0
		mov [W+1],[rp]
		pushW				
;********************************************************************************			
;sp!	( x -- ) point sp to x
;********************************************************************************	
Lspsto:	head	3,'sp!',Lrpat,0
spsto:	pops	W
		mov a, [W+1]
		swap	a, sp
		next
;********************************************************************************			
;rp!	( x -- ) point rp to x
;********************************************************************************	
Lrpsto:	head	3,'rp!',Lspsto,0
rpsto:	pops	W
		mov [W],0
		mov [rp],[W+1]
		next
;--------------------------------------------------------------------------------------------
;math
;-------------------------------------------------------------------------------------------
;+		( a b -- a+b) add top
Lplus:	head	1,'+',Lrpsto,0
plus:	pops	T0
		pops	W
		mov a, [T0+1]
		add	[W+1],a
		mov a,[T0]
		adc	[W],a
		pushW
;********************************************************************************			
;-		( a b -- b-a ) subtract top
;********************************************************************************	
Lminus:	head	1,'-',Lplus,0
minus:	pops	T0
		pops	W
		mov a, [T0+1]
		sub	[W+1],a
		mov a, [T0]
		sbb	[W],a
		pushW
;********************************************************************************			
; * 	( a b -- a*b ) 16 multiplication
;********************************************************************************	
Lmul:	head	1,'*',Lminus,0
mul:	pops	T0			;X
		pops	T1			;Y
		Multiply16_16_16	W,T0,T1
		pushW
;********************************************************************************	
;/mod	( a b -- b/a  b%a)
;********************************************************************************	
Ldivmod: head 4,'/mod',Lmul,0
 
divmod:	pops	T0
		pops	T1	
		call	div16
		pushs	W
		pushs	T1
		next
div16:          
		mov [W+0],00h			;clear Remainder
		mov [W+1],00h
		and F,fbh				;clear carry flag
		mov [T3],16		;load loop count to 16 for 16 bit division
d16u_1:         
		rlc [T1+1]				;rotate left through dividend and remainder
		rlc [T1+0]				
		rlc [W+1]				
		rlc [W+0]				
		mov [T2+0],[W+0]		;make backup of remainder
		mov [T2+1],[W+1]
		mov a,[W+1]			;subtract divisor from remainder
		sub a,[T0+1]
		mov [W+1],a
		mov a,[W+0]
		sbb a,[T0+0]
		mov [W+0],a
		jnc d16u_2					
		mov [W+1],[T2+1]		;if result is negative
		mov [W+0],[T2+0]		;restore remainder from backup
		and [T1+1],feh			;clear LSB of dividend
		jmp chkLcount16 
d16u_2:         
		or [T1+1],01h			;if result is positive set LSB of dividend
chkLcount16:
		dec [T3]			
		jnz d16u_1				;repeat till 16 bits are done
		ret		
;----------------------------------------------------------------------------------------------		
;memory ops
;----------------------------------------------------------------------------------------------
;w @		( x -- ram[x]) get word at RAM[x]
Lat:	head	1,'@',Ldivmod,0
at:		pops	T0
		mov	x,[T0+1]
		mov	a,[x+0]
		mov [W], a
		mov a, [x+1]
		mov [W+1], a
		pushW
 
;w c@		( x -- ram[x] ) get byte at RAM[x]
Lcat:	head	2,'c@',Lat,0
cat:	pops	T0
		mov x,[T0+1]
		mov [W],0
		mov a, [x]
		mov [W+1],a
		pushW
 
;w rom@	( x -- rom[x]) get a word in rom
Lromat:	head	4,'rom@',Lcat,0
romat:	pops	T0
		mov a, [T0]
		mov x,[T0+1]
		romx
		mov [W],a
		mov a,[T0]
		inc x
		adc a,0
		romx
		mov [W+1],a
		pushW
 
;w romc@	( x -- rom[x]) get a byte from rom
Lromcat:	head 5,'romc@',Lromat,0
romcat:	pops	T0
		mov a, [T0]
		mov x, [T0+1]
		romx
		mov [W+1],a
		mov [W],0
		pushW		
 
;w !	( a b -- ) store word b in ram[a]				
Lsto:	head	1,'!',Lromcat,0
sto:	pops	T0
		pops	T1
		mov x, [T0+1]
		mov a, [T1]
		mov [x], a
		mov a, [T1+1]
		mov [x+1], a
		next
 
;w c!	( a b -- ) store byte a in ram[b]
Lcsto:	head	2,'c!',Lsto,0
csto:	pops	T0
		pops	T1
		mov x, [T0+1]
		mov a, [T1+1]
		mov [x], a
		next		
 
;w +!	( a b -- ) add a to ram[b]	(word)
Lpsto:	head	2,'+!',Lcsto,0
psto:	pops	T0
		pops	T1
		mov x, [T0+1]	;x points to lsb of destination
		mov a, [T1+1]	;a=lsb of number
		add [x+1], a
		mov a, [T1]		;a=msb of number
		adc [x], a
		next
 
;w +c! ( a b -- ) add b to ram[a] (byte)		
Lpcsto: head	3,'+c!',Lpsto,0
pcsto:	pops	T0
		pops	T1
		mov x,[T0+1]
		mov a, [T1+1]
		add [x+0], a
		next
 
;----------------------------------------------------------------------------------------------
;system constants
;----------------------------------------------------------------------------------------------
 
LBASE:	head	4,'BASE',Lpcsto,0
BASE:	doCON
		dw	base
 
LHERE:	head	4,'HERE',LBASE,0
here:	doCON
		dw	HERE
 
LLAST:	head	4,'LAST',LHERE,0		
last:	doCON
		dw	LAST
Lcurrent: head 7,'CURRENT',LLAST,0
current: doCON
		dw	CURRENT
 
Lin:	head	2,'IN',Lcurrent,0
in:		doCON		
		dw	IN
 
LBLOC:	head	4,'BLOC',Lin,0
BLOC:	doCON
		dw	bloc
 
LLOC:	head	3,'LOC',LBLOC,0
LOC:	doCON
		dw	loc
;---------------------------------------------------------------------------------------------
;return stack ops
;---------------------------------------------------------------------------------------------
Ltor:	head	2,'>R',LLOC,0
tor:	pops	W
		pushr	W
		next
 
Lfromr:	head	2,'R>',Ltor,0				
fromr:	popr	W
		pushW
 
Lrat:	head	2,'R@',Lfromr,0
rat:	popr	W
		pushr	W
		pushW
 
;---------------------------------------------------------------------------------------------
;comparison
;---------------------------------------------------------------------------------------------
Leq:	head	1,'=',Lrat,0
eq:		pops	T0
		pops	W
		mov a, [W]
		cmp	a, [T0]
		jnz	false
		mov a, [W+1]
		cmp	a,[T0+1]
		jnz	false
negone:		
true:	mov a, -1
		push a
		push a
		next
zero:		
false:	mov a, 0
		push a
		push a
		next
;<	( a b -- t|f ) true if a<b false otherwise
Llt:	head	1,'<',Leq,0
lt:		pops	W
		pops	T0
		mov a, [T0]
		cmp	a, [W]
		jc	true
		jz	lt0
		jmp	false
lt0:	mov a,[T0+1]
		cmp	a,[W+1]
		jc	true
		jmp	false
 
Lexecute: head	7,'execute',Llt,0
execute:	ret		
;******************************************************************************************
;w ?key   ( -- T char | F ) If there is a character, return true and char
;******************************************************************************************	
Lqkey:	head    4,'?key',Lexecute,0
qkey:	mov A,  REG[UART_1_RX_CONTROL_REG]
		and	a, 8
		jnz get_char
		ljmp false
get_char:
		mov A, REG[UART_1_RX_BUFFER_REG]
		mov [W], 0
		mov [W+1],a
		pushs W
		ljmp true		
;******************************************************************************************	
;w key    ( -- char )  get a character from the UART
;******************************************************************************************	
Lkey:	head	3,'key',Lqkey,0
key:	colon
key0:	dw	qkey,zbr,key0
		dw	exit
 
Lregsto:	head 4,'reg!',Lkey,0
regsto:	pops	W
		pops	T0
		cmp	[W],1
		jnz	regsto0
		m8c_SetBank1
regsto0:		
		mov x, [W+1]
		mov a, [T0+1]
		mov reg[x],a
		m8c_SetBank0
		next
 
Lregat:	head 4,'reg@',Lregsto,0
regat:	pops	W
		cmp	[W],1
		jnz	regat0
		m8c_SetBank1
regat0:	mov x,[W+1]
		mov a,reg[x]		
		m8c_SetBank0
		mov [W+1],a
		mov [W],0
		pushW
 
 
Lregor:	head	5,'regor',Lregat,0
regor:	pops	W
		pops	T0
		cmp	[W],1
		jnz	regor0
		m8c_SetBank1
regor0:	mov x, [W+1]
		mov a,reg[x]
		or a,[T0+1]
		mov reg[x],a
		m8c_SetBank0
		next
 
Lregand: head 6,'regand',Lregor,0
regand:	pops	W
		pops	T0
		cmp	[W],1
		jnz	regand0
		m8c_SetBank1
regand0:mov x, [W+1]
		mov a, reg[x]
		and a, [T0+1]
		mov reg[x],a
		m8c_SetBank0
		next
 
Lregxor: head 6,'regxor',Lregand,0
regxor:	pops	W
		pops	T0
		cmp	[W],1
		jnz	regxor0
		m8c_SetBank1
regxor0:mov x, [W+1]
		mov a,reg[x]
		xor a, [T0+1]
		mov reg[x],a
		m8c_SetBank0
		next
 
Land:	head	3,'and',Lregxor,0       ; b000 and word
pand:	pops	T0
		pops	T1
		mov a, [T0+1]
		and a, [T1+1]
		mov [W+1],a
		mov a, [T0]
		and a, [T1]
		mov [W],a
		pushW
 
Lor:	head	2,'or',Land,0            ; b000  or word
por:	pops	T0
		pops	T1
		mov a, [T0+1]
		or a, [T1+1]
		mov [W+1],a
		mov a, [T0]
		or a, [T1]
		mov [W],a
		pushW		
 
Lxor:	head	3,'xor',Lor,0       ; b000  xor word
pxor:	pops	T0
		pops	T1
		mov a, [T0+1]
		xor a, [T1+1]
		mov [W+1],a
		mov a, [T0]
		xor a, [T1]
		mov [W],a
		pushW				
 
Lnot:	head	3,'not',Lxor,0         ; b000  not word
not:	pops	W
		mov a, [W+1]
		cpl a
		mov [W+1], a
		mov a,[W]
		cpl	a
		mov [W],a
		pushW
 
Lnegate:head	6,'negate',Lnot,0
negate:	colon
		dw	not,plone,exit
 
Ltwostar:head	2,'2*',Lnegate,0
twostar:pops	W
		asl	[W+1]					;shift left ignoring carry (low byte)
		rlc	[W]						;shift left including carry	(high byte)
		pushW
 
Ltwodiv:head	2,'2/',Ltwostar,0
twodiv:	pops	W
		asr	[W]						;shift right ignoring carry (high byte)
		rrc	[W+1]					;shift right including carry (low byte)1]
		pushW						
 
 
Lshout:head	5,'shout',Ltwodiv,0      ; b001   shift out ?
shout:	pops	T0
		mov [W],0
		mov [W+1],0
		asr [T0]					;shift right ignoring carry (high byte)
		rrc [T0+1]					;shift right including carry (low byte)
		rlc [W+1]					;put the carry value into lsb
		pushs T0					;push the shifted source
		pushW						;push the lsb
 
 
 
Lzeq:	head	2,'0=',Lshout,0
zeq:	pops	W
		mov	a,[W]
		or	[W+1],a
		jz	true
		jmp	false
 
Lgt:	head	1,'>',Lzeq,0
gt:		colon
		dw	swop,lt,exit
 
Lneq:	head	2,'<>',Lgt,0
neq:	colon
		dw	eq,zeq,exit
 
Ldotq:	db	2,46,34      ; 2 chars '." '   dot-quote dot quote   b001
		dw	Lneq
		db	1
dotq:	colon
		dw	lit,xquote,tickw
dotq0:	dw	word,zbr,dotq1	
		dw	lit,TIB
		dw	lit,cnt,cat,dup,tick
dotq2:	dw	swop,dup,cat,tick
		dw	plone,swop,mione,dup
		dw	nzbr,dotq2
		dw	drop,drop,exit		
dotq1:	dw	accept,br,dotq0		
 
Lcount:	head	5,'count',Ldotq,0
count:	colon
		dw	dup,romcat,swop,plone,swop,exit
 
Ltype:	head	4,'type',Lcount,0
type:	colon
type_loop:
		dw	swop,dup,romcat,emit,plone
		dw	swop,mione,dup
		dw	zbr,type_done
		dw	br,type_loop
type_done:
		dw	drop,drop,exit		
 
Laccept:head	6,'accept',Ltype,0
accept:	colon
		dw	reset_in					;reset IN
		dw	lit,'>',emit				;prompt
accept0:dw	key							;get a char
		dw	dup, lit,28h, pxor
		dw	zbr,comment
accept1:dw	dup,emit						;print it
		dw	dup,lit,13,pxor				;is it a CR
		dw	zbr, EOL					;then handle it
		dw	dup,lit,8,pxor				;is it a BKSP
		dw	zbr,BKSP					;then handle it
		dw	in, cat, csto				;store in TIB
		dw	in, cat, plone,dup
		dw	lit, EOT,lt					;end of TIB?
		dw	zbr,TIB_FULL
		dw	in,csto
		dw	br,accept0					;do it again
comment:dw	drop
comment0:
		dw	key,lit,29h,pxor
		dw	nzbr, comment0
		dw	br,accept0		
TIB_FULL:
		dw	xquote
		db	11
		ds	'TIB FULL!'
		db	13,10
		dw	br,EOL0
EOL:	dw	lit,10,emit					;send a LF
		dw	drop
EOL0:	dw	zero						;replace CR with 0
		dw	in,cat,csto					;to mark end
		dw	reset_in,exit				;reset and exit						
BKSP:	dw	in,cat,lit,TIB,pxor
		dw	zbr,BKSP0
		dw	lit,20h,emit				;wipe out character
		dw	emit						;back up again
		dw	in,cat,mione				;back up IN
		dw	in,csto
		dw	br,accept0					;get another 
BKSP0:	dw	drop,lit,'>',emit
		dw	br,accept0		
reset_in: colon
		dw	lit,TIB,in,csto,exit
 
 
Llfa:	head	3,'lfa',Laccept,0
lfa:	colon
		dw	count,plus,exit
 
Lcfa:	head	3,'cfa',Llfa,0
cfa:	colon
		dw	lfa,lit,3,plus,exit
 
Llex:	head	3,'lex',Lcfa,0
lex:	colon
		dw	lfa,lit,2,plus,exit		
 
;word ( -- T|F )	moves next token to TIB.  Returns T if a word if a word is assembled, 
;					returns false if not.
word:	mov x, TIB
		mov [cnt], 0
skip:	mvi	a,[IN]
		jz	false
		cmp	a, 33
		jc	skip		;ignore white space		
scan:	mov	[x+0], a
		inc	[cnt]
		inc	x
		mvi	a,[IN]
		jz	word_done1
		cmp	a, 33
		jc	true
		jmp	scan
word_done1:
		dec	[IN]		;so that next time word fails
		jmp	true
 
swab:	pops	T0
		mov [W+1], [T0]
		mov [W],[T0+1]
		pushW
 
 
d2a:	colon
		dw	dup,lit,9,gt
		dw	zbr,d2a0
		dw	lit,7,plus
d2a0:	dw	lit,30h,plus,emit,exit		
 
Ldot:	head	1,'.',Llex,0		
dot:	colon
		dw	zero,swop
dot0:	dw	BASE,cat,divmod,swop,tor
		dw	swop,plone,swop,dup,nzbr,dot0
		dw	drop
dot1:	dw	fromr,d2a,mione,dup,nzbr,dot1
		dw	drop,exit		
 
Lspc:	head 3,'spc',Ldot,0
spc:	colon
		dw	lit, 20h, emit, exit
 
Lcrlf:	head	4,'crlf',Lspc,0
crlf:	colon
		dw	lit,13,emit
		dw	lit,10,emit,exit
 
Lwords:	head	5,'words',Lcrlf,0
words:	colon
		dw	last, at	
words_loop:
		dw	dup,count,type,lit,20h,emit
		dw	lfa,romat,dup
		dw	zbr,words_done
		dw	br,words_loop
words_done:
		dw	drop,crlf,exit			
 
;match	( nfa -- t|f ) see if TOS and word match
match:	mov	[T0], cnt
		mov	[W],[cnt]
		inc	[W]
		pop	x
		pop	a
match_loop:
		push	a
		romx
		mov [W+1], a
		mvi	a, [T0]
		cmp	a,[W+1]
		jnz	no_match
		pop	a
		inc	x
		adc	a, 0
		dec	[W]
		jz	true
		jmp	match_loop
no_match:
		pop	a
		jmp	false
 
; find ( -- [nfa t]|f ) see if WORD is in the dictionary. If it is,
;						return true and nfa, else, return false.
find:	colon
		dw	last, at
find_loop:
		dw	dup, match
		dw	zbr, find_next
		dw	true,exit				;leaves nfa and true					
find_next:
		dw	lfa,romat,dup
		dw	zbr,not_found
		dw	br,find_loop
not_found:
		dw	drop,false,exit
 
;>dig try to convert WORD to a number returns true and value or false
todig:	colon
		dw	lit,cnt,cat,lit,TIB
		dw	zero,tor
todig_loop:
		dw	dup,cat,qdig
		dw	zbr,not_dig
		dw	fromr,BASE,	cat,mul,plus,tor
		dw	plone,swop,mione,dup
		dw	zbr,todig_done
		dw	swop,br,todig_loop
todig_done:
		dw	drop,drop,fromr,true,exit
not_dig:
		dw	drop,drop,drop,fromr,drop,false,exit				
 
 
;( char -- [t n]|[f char] )
qdig:	pops	W
		mov [W],0
		sub	[W+1],48
		jc	not_dig0
		cmp [W+1],10
		jc	is_dig
		sub	[W+1],7
		jc	is_dig
		cmp	[W+1],16
		jc is_dig
		sub	[W+1],32
		jc	not_dig0
		cmp	[W+1],16
		jc	is_dig
not_dig0:
		pushs	W	
		jmp	false		
is_dig:	mov a, [W+1]
		cmp	a, [base]
		jc	digit
		jmp	not_dig0
digit:	pushs	W
		jmp	true
;----------------------------------------------------------------------------------------------------
;compiler
;----------------------------------------------------------------------------------------------------
 
Lblkat:	head	4,'blk@',Lwords,0
blkat:	pops	W	
		lcall	read_blk
		next
 
 
 
Lblksto: head	4,'blk!',Lblkat,0
blksto:	pops	W
		lcall	blk_write
		next
 
 
;w >bloc ( addr -- loc bloc ) 	convert an address to a block and location for
;						FLASH ROM access
Ltobloc: head 5,'>bloc',Lblksto,0
tobloc:	colon
		dw	lit,40h,divmod,exit
 
;w >addr ( bloc loc -- addr )	convert a bloc/loc to an address		
Ltoaddr: head 5,'>addr',Ltobloc,0
toaddr:	colon
		dw	lit,40h,mul,plus,exit
 
;w ' ( char -- ) 	tick - write a byte to FLASH.  Writes to FLASH BUFFER (RAM 0-3f).  When
;					buffer is full, writes to FLASH and resets the buffer to bloc+1.
Ltick:	db	1,96
		dw	Ltoaddr
		db	0
tick:	colon
		dw	LOC,cat,csto	
		dw	LOC,cat,plone		
		dw	dup,lit,40h,pxor,zbr,reload		
		dw	LOC,csto
		dw	exit
reload:	dw	drop,BLOC,cat,blksto
		dw	BLOC,cat,plone,BLOC,csto
		dw	zero,LOC,csto		
		dw	exit
 
tickw:	colon
		dw	dup,swab,tick,tick,exit
 
new_here: colon
		dw	LOC,cat,BLOC,cat,toaddr,here,sto
		dw	exit
 
;w create 
Lcreate:head	6,'create',Ltick,0
create:	colon
		dw	here,at,tobloc,BLOC,csto,LOC,csto
		dw	BLOC,cat,blkat
create1:dw	word,zbr,create2
		dw	lit,cnt,cat,plone
		dw	lit,cnt
create_loop:								;compile name
		dw	dup,cat,tick
		dw	plone,swop,mione,dup
		dw	zbr,created
		dw	swop,br,create_loop
created:dw	drop,drop,last,at,tickw			;compile lex
		dw	zero,tick
		dw	BLOC,cat,blksto									;write it
		dw	here,at,last,sto								;here->last 
		dw	new_here										;bloc/loc->here
		dw	exit
create2:dw	accept,br,create1
 
;w constant
Lconstant: head	8,'constant',Lcreate,0
constant:
		colon
		dw	create
		dw	lit,7ch,tick		;compile lcall
		dw	lit,_doCON,tickw	;compile _doCON
		dw	tickw				;compile TOS
		dw	BLOC,cat,blksto		;write it
		dw	new_here
		dw	exit
 
;w table 
Ltable:	head	5,'table',Lconstant,0
tabl:	colon
		dw	create
		dw	lit,7ch,tick
		dw	lit,_next,tickw			;compile doTABLE
table0:	dw	word,zbr,table1		
		dw	todig,zbr,table_err
		dw	tick,br,table0
table_err:
		dw	lit,TIB,cat,lit,22h,pxor,zbr,table_done
		dw	br, compile_err
table_done:
		dw	BLOC,cat,blksto		;write it
		dw	new_here
		dw	exit
table1:	dw	accept,br,table0
 
 
 
;w :    head of compile
Lcompile:	head	1,':',Ltable,0
compile:
		colon
		dw	create
		dw	lit,7ch,tick
		dw	lit,_colon,tickw		;compile LCALL _colon
compile_loop:
		dw	word,zbr,compile0
		dw	find,zbr,compile_num
		dw	dup,lex,romcat,zbr,compile_word
		dw	cfa,execute,br,compile_loop
compile_word:
		dw	cfa,tickw,br,compile_loop
compile_num:
		dw	todig,zbr,compile_err
		dw	lit,lit,tickw,tickw
		dw	br,compile_loop
compile_err:
		dw	print
		dw	xquote
		db	13
		ds	' not found.'
		db	13,10
		dw	last,at,here,sto
		dw	last, at,lfa,romat
		dw	last,sto,save
		dw	abort						
compile0:
		dw	accept,br,compile_loop		
 
immed:	equ	1
Lsemi:	db	1,59
		dw	Lcompile
		db	immed
semi:	colon
		dw	lit,exit,tickw
		dw	BLOC,cat,blksto
		dw	new_here
		dw	quit
 
Lforget:	head	6,'forget',Lsemi,0
forget:		colon
forget1:dw	word,zbr,forget0
		dw	find,zbr,forget2
		dw	dup, here,sto
		dw	lfa,romat,last,sto,save,exit
forget2:dw	xquote
		db	24
		ds	'not in the dictionary.'
		db	13,10
		dw	quit		
forget0:dw	accept,br,forget1
 
;w startup   <my_word><startup> will make FORTH start at <my_word> rather than <cold>
Lstartup:	head	7,'startup',Lforget,0
startup:	colon
startup1:
		dw	word,zbr,startup0
		dw	find,zbr,forget2
		dw	cfa,current,sto
		dw	save,exit		
startup0:
		dw	accept,br,startup1		
 
Lbootat:	head	5,'boot@',Lstartup,0
bootat:	colon
		dw	lit,ffh,blkat,exit		
 
Lbootsto:	head	5,'boot!',Lbootat,0		
bootsto: colon
		dw	lit,ffh,blksto,exit		
 
Lsave:	head	4,'save',Lbootsto,0
save:	colon
		dw	bootat
		dw	last,at,lit,vlast,sto
		dw	here,at,lit,vhere,sto
		dw	current,at,lit,vcurr,sto
		dw	bootsto
		dw	exit
 
 
;-------------------------------------------------------------------------------------------------
;interrrupt words
;-------------------------------------------------------------------------------------------------
 
;w GIE       enable general interrupt	
Lgie:	head	3,'GIE',Lsave,0
gie:	M8C_EnableGInt
		next		
;w GID    disable general interrupt		
Lgid:	head	3,'GID',Lgie,0
gid:	M8C_DisableGInt
		next
 
;w sar1     successive apoximation register ??
Lsar1:	head	4,'sar1',Lgid,0
sar1:	mov 	a, 3
		lcall	sar1_SetPower
		lcall	sar1_GetSample
		mov		x,0
		push	x
		add		a, 20h
		push 	a
		lcall	sar1_Stop
		next	
 
;w sar2    successive aproximation register ??
Lsar2:	head	4,'sar2',Lsar1,0
sar2:	mov	a,3
		Lcall	sar2_SetPower
		lcall	sar2_GetSample
		mov		x,0
		push	x
		add		a, 20h
		push	a
		lcall	sar2_Stop
		next
 
;w sar3    successive aproximation register ??
Lsar3:	head	4,'sar3',Lsar2,0
sar3:	mov		a,3
		Lcall 	amp_Start
		mov 	a,3
		lcall	sar3_SetPower
		lcall	sar3_GetSample
		mov		x,0
		push	x
		add		a, 20h
		push	a
		lcall	sar3_Stop
		Lcall	amp_Stop		
		next
 
;w temp  
Ltemp:	head 	4,'temp',Lsar3,0	
temp:	mov 	reg[INT_VC],0
		M8C_EnableGInt
		lcall	FlashTemp_1_Start
temp_loop:
		lcall	FlashTemp_1_fIsData
		cmp		a,0
		jz		temp_loop
		lcall	FlashTemp_1_cGetData
		lcall	FlashTemp_1_Stop
		mov 	[W+1], a
		mov 	[W], 0
		M8C_DisableGInt
		pushW			
;--------------------------------------------------------------------------------------------------		
;control structures
;--------------------------------------------------------------------------------------------------
mark:	colon
		dw	LOC,cat,BLOC,cat,toaddr,exit
 
unmark:	colon
		dw	tickw,exit		
 
;w begin
Lbegin:	head	5,'begin',Ltemp,immed
begin:	colon
		dw	mark,exit		
;w again
Lagain:	head	5,'again',Lbegin,immed
again:	colon
		dw	lit,br,tickw,unmark,exit
;w until		
Luntil:	head	5,'until',Lagain,immed
until:	colon
		dw	lit,nzbr,tickw
		dw	unmark
		dw	exit						
 
;w if
Lif:	head	2,'if',Luntil,immed
pif:	colon
		dw	lit,zbr,tickw
		dw	mark,zero,tickw,exit
; (addr addr -- ) 
resolve:	colon
		dw	BLOC,cat,blksto				;save current blk
		dw	BLOC,cat,tor,LOC,cat,tor	;save current BLOC ptr
		dw	tobloc						;convert mark to BLOC
		dw	BLOC,csto,LOC,csto			;put in BLOC ptr
		dw	BLOC,cat,blkat				;get code to be resolved
		dw	fromr,fromr,toaddr			;convert jmp address
		dw	dup,tickw					;compile it
		dw	BLOC,cat,blksto				;save code
		dw	tobloc						;convert to BLOC
		dw	BLOC,csto,LOC,csto			;restore BLOC ptr
		dw	BLOC,cat,blkat				;restore blk
		dw	exit
 
;w endif
Lthen:	head	5,'endif',Lif,immed
then:	colon
		dw	resolve,exit			
 
;w else		
Lelse:	head	4,'else',Lthen,immed
pelse:	colon
		dw	lit,br,tickw
		dw	mark
		dw	zero,tickw
		dw	tor,resolve,fromr,exit			
 
Ldo:	head	2,'do',Lelse,immed
do:		colon
		dw	mark,lit,tor,tickw,exit
 
;break forces premature end of do by replaceing the return stack with 1		
Lbreak:	head	5,'break',Ldo,0
break:	colon
		dw	fromr, fromr, drop, lit, 1, tor,tor
		dw	exit	
 
Lloop:	head	4,'loop',Lbreak,immed
loop:	colon
		dw	lit,fromr,tickw
		dw	lit,mione,tickw
		dw	lit,dup,tickw
		dw	lit,nzbr,tickw
		dw	unmark			
		dw	lit,drop,tickw
		dw	exit
 
Lwhile:	head	5,'while',Lloop,immed
while:	colon
		dw	pif,exit
 
Lwend:	head	4,'wend',Lwhile,immed
wend:	colon
		dw	swop,again,then,exit				
;--------------------------------------------------------------------------------------------------
;i/o words
;--------------------------------------------------------------------------------------------------
 
seperate:
		rlc	[W]
		rlc	[W]
		mov a,1
seperate0:
		or	[W+1],0
		jz	seperate1
		rlc	a
		dec	[W+1]
		jmp	seperate0
seperate1:
		mov [W+1],a
		mov x,[W]
		ret				
 
 
Linput: head	5,'input',Lwend,0
input:	pops	W
		call	seperate
		mov a, [W+1]
		cpl a
		mov [W], a
		M8C_SetBank1
		mov a, reg[x]
		and a, [W]
		mov reg[x], a
		mov a, reg[x+1]
		or a, [W+1]
		mov reg[x+1], a
		M8C_SetBank0
		next
 
Lstrong: head	6, 'strong',Linput,0
strong:	pops	W
		call	seperate
		mov a, [W+1]
		cpl	a
		mov [W], a
		M8C_SetBank1
		mov a, reg[x]
		or a, [W+1]
		mov reg[x], a
		mov a, reg[x+1]
		and a, [W]
		mov reg[x+1], a
		M8C_SetBank0
		next
 
Lpullup:	head 6,'pullup',Lstrong,0
pullup:	pops	W
		call	seperate
		M8C_SetBank1
		mov a, reg[x]
		or a, [W+1]
		mov reg[x], a
		mov a, reg[x+1]
		or a, [W+1]
		mov reg[x+1], a
		M8C_SetBank0
		next
 
Lpulldown: head 8,'pulldown',Lpullup,0
pulldown: pops	W
		call seperate
		mov a, [W+1]
		cpl a
		mov [W],a
		M8C_SetBank1		
		mov a, reg[x]
		and a, [W]
		mov reg[x], a
		mov a, reg[x+1]
		and a, [W]
		mov reg[x+1],a
		M8C_SetBank0
		next
 
Lon:	head	2,'on',Lpulldown,0
pon:	pops	W
		call	seperate
		mov a,reg[x]
		or a,[W+1]
		mov reg[x], a
		next
 
 
Loff:	head	3,'off',Lon,0		
poff:	pops	W
		call	seperate
		mov a,[W+1]
		cpl	a
		mov [W+1],a
		mov a,reg[x]
		and a, [W+1]
		mov reg[x],a
		next
 
Ltoggle: head	6,'toggle',Loff,0		
toggle:	pops	W
		call	seperate
		mov a, reg[x]
		xor a, [W+1]
		mov reg[x],a
		next		
 
Linp:	head	3,'inp',Ltoggle,0				
inp:	pops	W
		call	seperate
		mov [W],0
		mov a,reg[x]
		and a, [W+1]
		jz	inp0
		mov [W+1],1
		pushW
inp0:	mov [W+1],0
		pushW	
 
save_mode:	
		mov a, reg[x]
		mov [T0], a
		mov a, reg[x+1]
		mov [T0+1], a						
		ret
 
restore_mode:
		M8C_SetBank1
		mov a, [T0]
		mov reg[x],a
		mov a, [T0+1]
		mov reg[x+1],a			;port mode restored
		M8C_SetBank0
		ret
 
 
;pulsout ( length pin -- )		
Lpulsout: head	7,'pulsout',Linp,0
pulsout:pops	W
		call	seperate
		cpl a
		mov [W],a				;W+1=pin, W=~pin,
		M8C_SetBank1
		call save_mode
		and a, [W]				
		mov reg[X+1], a			;DM1=0
		mov a, reg[x]
		or a, [W+1]
		mov reg[x], a			;DM0=1 pin is strong
		M8C_SetBank0
		pops	T1				;get pulse length
		mov a, reg[x]			;
		xor a, [W+1]			;
		mov reg[x], a			;pin is opposite
pulsout_loop:
		lcall	OneWireSW_1_Delay50u
		dec		[T1+1]
		sbb		[T1], 0
		jnc		pulsout_loop
		mov a, reg[x]			
		xor a, [W+1]
		mov reg[x], a			;pin is opposite
		call restore_mode
		next
 
;pulsin				
Lpulsin: head	6,'pulsin',Lpulsout,0
pulsin:	pops	W
		call	seperate
		cpl	a
		mov [W], a			;x=port, W=~pin, W+1=pin
		mov [T1],0
		mov [T1+1],0		;initialize counter
		M8C_SetBank1
		call save_mode
		and	a, [W]
		mov reg[x+1],a		;DM1=0
		mov a, reg[x]
		and a, [W]			
		mov reg[x],a		;dm0=0
		M8C_SetBank0
		pops	T2			
		mov a, [T2+1]
		and a, [W+1]
		mov [T2],a			;T2=state
pulsin_hold:		
		mov a, reg[x]		;sample pin
		and a, [W+1]
		cmp a, [T2]
		jnz	pulsin0			;if state <> start measuring
		inc	[T1+1]
		adc	[T1],0
		jnc	pulsin_hold		;continue sampling until timeout
		jmp	pulsin_fail		;timeout, return 0
pulsin0:mov [T1],0
		mov [T1+1],0
pulsin_edge:
		mov a,reg[x]
		and a, [W+1]		;sample pin
		cmp	a, [W+1]
		jnz	get_pulse		;if state changes, start measuring
		inc	[T1+1]
		adc	[T1],0
		jnc	pulsin_edge		;if no time out, sample again
		jmp	pulsin_fail		;timeout, return 0
get_pulse:
;		lcall	OneWireSW_1_Delay50u
		mov 	a,reg[x]
		and		a, [W+1]		;sample pin
		cmp		a, [W+1]		;
		jnz		pulsin_done		;when state changes, you're done
		inc		[T1+1]
		adc		[T1],0
		jnc		get_pulse		;continue until pulsedone or timeout
pulsin_fail:
		call	restore_mode
		ljmp	false		
pulsin_done:
		call	restore_mode
		pushs	T1		
		next
 
;w delay	(x -- ) delay for length x * 50 usec
Ldelay:	head	5,'delay',Lpulsin,0
delay:	pops	W
delay_loop:
		lcall	OneWireSW_1_Delay50u
		dec		[W+1]
		sbb		[W],0
		jnc		delay_loop
		next		
 
;w ow_rst		one wire reset
Lowrst:	head	6, 'OW_rst',Ldelay,0
owrst:	lcall	OneWireSW_1_Reset
		mov		[W+1],a
		mov		[W],0
		pushW
 
;w OWwr:    one wire write
Lowwr:	head 5, 'OW_wr',Lowrst,0
owwr:	pops	W
		mov		a, [W+1]
		lcall	OneWireSW_1_WriteByte
		next
 
;w OWwrs:	one wire write strong
Lowwrs:	head 6, 'OW_wrs',Lowwr, 0
owwrs:	pops	W
		mov		a, [W+1]
		lcall	OneWireSW_1_WriteByteStrong
		next
 
;w OWrd:          one wire read byte
Lowrd:	head 5, 'OW_rd', Lowwrs, 0
owrd:	lcall	OneWireSW_1_ReadByte
		mov		[W+1], a
		mov		[W], 0
		pushW		
;--------------------------------------------------------------------------------------------------
print:	colon
		dw	lit,cnt,cat
		dw	lit,TIB
print_loop:
		dw	dup,cat,emit,plone
		dw	swop,mione,dup
		dw	zbr,printq
		dw	swop,br,print_loop
printq:	dw	drop,drop
		dw	exit
 
interpret:
		colon
interpret_loop:		
		dw	word, zbr, interpret0
		dw	find,zbr,qnum
		dw	cfa,execute,br,interpret_loop
qnum:	dw	todig
		dw	zbr,qtok
		dw	br,interpret_loop
qtok:	dw	print
		dw	lit,'?',emit,crlf	
interpret0:
		dw	exit		
 
;w hex    change base to 16D
Lhex:	head	3,'hex',Lowrd,0
hex:	colon
		dw	lit,10h,BASE,csto,exit
 
;w hex    change base to 10D		
Ldec:	head	7,'decimal',Lhex,0
decimal: colon
		dw	lit,0ah,BASE,csto,exit
 
;w hex    change base to 2D
Lbinary: head	6,'binary',Ldec,0
binary:	colon
		dw	lit,2,BASE,csto,exit
 
 
;w quit
Lquit:	head	4,'quit',Lbinary,0
quit:	colon
		dw	lit,rp0,rpsto	
quit_loop:
		dw	spat,dot,rpat,dot
		dw	accept,interpret
		dw	xquote
		db	4
		ds	'ok'
		db	13,10
		dw	br,quit_loop
 
;w abort
Labort:	head	5,'abort',Lquit,0				
abort:	colon
		dw	lit,sp0,spsto
		dw	quit
 
;w default
Ldefault:	head 7,'default',Labort,0		
default:	colon
		dw	lit,d_top,last,sto
		dw	lit,new_code,here,sto
		dw	hex
		dw	lit,cold,current,sto
		dw	exit
 
;w init
Linit:	head	4,'init',Ldefault,0		
init:	colon
		dw	lit,Vlast,romat,last,sto
		dw	lit,Vhere,romat,here,sto
		dw	lit,Vcurrent,romat,current,sto
		dw	hex
		dw	exit			
d_top:						
 
;w cold
Lcold:	head	4,'cold',Linit,0				
cold:	colon
		dw	lit,12,emit
		dw	lit,201h,inp
;		dw	lit,101h,inp		;use pin 1.1 for 27143    b001   look for different pins for 29466
		dw	nzbr,saftey
		dw	init,br,cold0
saftey:	dw	default	
		dw	lit,40h,emit	
cold0:	dw	xquote
		db	endend - $   ;  end minus here  b001   this is length of string
		ds	'PSoC FORTH v2.01 beta001 b001  updated 20070821' ; b001
endend:		db	13,10    ; b001
		dw	abort
 
		org	2000h
new_code:
 
 
 
	org	3fc0h
Vcurrent:	dw	cold		;3fc0
Vlast:		dw	d_top		;3fc2
Vhere:		dw	new_code	;3fc4
Vbase:		db	10h,0,0,0	;3fc6