Forth/PSoC Forth

From Wikibooks, open books for an open world
< Forth
Jump to: navigation, search

How to install PSoC Forth[edit]

Ingredients:

  • A PSoC microcontroller
  • A PSoC flash-burner such as the ICE-Cube (it lets you debug, set breakpoints, single-step through your code, etc.) or the MiniProg (costs less).
  • A PC that can run PSoC Designer for Windows or the M8Cutils for Linux.
  • Create the hex file "psoc_forth.hex": either
    • If you have a Windows box, use PSoC Designer (details below), or
    • If you have a Linux box or a Macintosh, use M8Cutils.
    • (Both development tools are free downloads.)
  • Use the PSoC programmer to burn the hex file into the microcontroller.

Creating the hex file with M8Cutils[edit]

One-time install:


Creating the hex file with PSoC designer[edit]

Unfinished -- needs work

One-time install:

  • Run PSoC Designer to create a new project
    • Create new project. New project name: "interactive" (without quotes). Base part: 27443.
    • Generate 'Main' file using: Assembler. Finish.
  • Download "One Wire User Module" by Wes Randall from http://www.psocdeveloper.com/uploads/media/OneWire_v1.3.3.zip , and install the "OneWireSW" custom user module. (FIXME: how?)
  • In the "user module selection view", choose the "user modules" you might need: (You can select and place one at a time, or select all of them, then place all of them).
    • Digital Comm: Uart (double-click on it to create UART_1)
    • Temperature: FlashTemp
    • Three "SAR6" modules -- rename them "sar1", "sar2", and "sar3".
    • One "OneWireSW" module
    • One INSAMP -- rename it "amp".
  • In "interconnect view", place all the user modules (right-click on each one and choose "place"). (The "placed" modules have a thick colored rectangle around them. The ones you haven't placed yet don't have any rectangle or only a thin black rectangle around them.)
  • In the "ApplicationEditor" view, hit "Build" (F7).
    • You should get the message "0 error(s) 0 warning(s)".
  • Copy the psoc_forth.asm source code into a file "psoc_forth.asm", in the same directory as the "main.asm" we just created.
  • Download "Algorithm - Unsigned Multiplication - AN2032" by Dave Van Ess, and extract the file "unsignedmath.inc" and put it in the same directory as "psoc_forth.asm":
    • (Um... wouldn't "Algorithm - Signed Multi-Byte Multiplication - AN2038" be better?)
  • In the "ApplicationEditor" view, select Project | Add to project | Files... and select "psoc_forth.asm".
  • In the "ApplicationEditor" view, hit "Build" (F7).
    • You should get the message "0 error(s) 0 warning(s)". (FIXME: ... I never got this far ...)
  • Edit the source file "main.asm" and just before the ".terminate", add the line
        jmp start ; start Forth interpreter
  • In the "ApplicationEditor" view, hit "Build" (F7) to create the hex file.

Interactive development[edit]

  • Connect serial port on the microcontroller to a terminal. (Perhaps the same PC used above, running a terminal emulator; or a PDA serial port, or a dumb terminal.)
  • ...

The source[edit]

;    psoc_forth.asm -- kernel 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 operations
;----------------------------------------------------------------------------------------------
;@		( 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 operations
;---------------------------------------------------------------------------------------------
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

The source: alternate[edit]

Some slight changes and notes by Gus Calabrese and Bill Goodrich, in hopes of creating a workable version for newer PSOCs, like our CY8C29466.

;    Kernel 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 operations
;----------------------------------------------------------------------------------------------
;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 operations
;---------------------------------------------------------------------------------------------
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

David, is this a good technique, wiki-wise, to include changes we've made? - Bill

Sure, that's great. After I figure out what your changes mean, I'll edit Wikibooks:PSoC Forth so it shows only one version -- the latest and greatest.

This latest version still supports all the chips that the original one ran on, right? (People can always go to Wikibooks:PSoC Forth history to see the original version or any other version).

"What is rp? Return pointer?" Yes, it's the pointer to the top of the "return stack". Would it be less confusing if we did a search-and-replace to rename it "RSP", so we're using the same terminology as Brad Rodriguez and the FigUK: "The Heart of Forth" articles?

Right now the most mystifying (to me) change is adding "w" to a bunch of comments -- for example, I see ";drop ( x -- ) drop TOS" changed to ";w drop ( x -- ) drop TOS" . Does that "w" mean anything to you?

I found that it is not very practical to try to fit this to the newer 466 chips. The best I could do was to get the newer chips to "emulate" Pforth, which was not very useful. It would be better to start from scratch. Chris Burns

History[edit]

  • 2003: Originally written by Christopher W. Burns.
  • 2006: Maintenance taken over by David Cary (starting from version 2.01 ).
  • 2008 - Is anyone still interested in PSOC Forth? Chris Burns
  • 2008 - Am I the only one still interested in a PSoC Forth? -- DavidCary
             20090208 No, David I am interested in supporting PSOC Forth. psocforth@nope9.com

Further reading[edit]