Forth/PSoC Forth
< Forth
成分
- 一个 PSoC 微控制器
- 一个 PSoC 闪存烧录器，例如 ICE-Cube（它允许您调试、设置断点、单步执行代码等）或 MiniProg（成本更低）。
- 一台可以运行 PSoC Designer for Windows 或 M8Cutils for Linux 的 PC。
- 创建 hex 文件 "psoc_forth.hex"：以下两种方式任选
- 如果您使用的是 Windows 系统，请使用 PSoC Designer（详细说明见下文），或者
- 如果您使用的是 Linux 或 Macintosh 系统，请使用 M8Cutils。
- （两种开发工具都可以免费下载。）
- 使用 PSoC 编程器将 hex 文件烧录到微控制器中。
一次性安装
- 安装 M8Cutils for Linux http://m8cutils.sourceforge.net/.
未完成 - 需要改进
一次性安装
- 安装 PSoC Designer for Windows http://www.cypress.com/psocdesigner.
- 运行 PSoC Designer 创建新项目
- 创建新项目。新项目名称："interactive"（不带引号）。基本部件：27443。
- 使用“汇编器”生成“Main”文件。完成。
- 从 http://www.psocdeveloper.com/uploads/media/OneWire_v1.3.3.zip 下载 Wes Randall 的“One Wire 用户模块”，并安装“OneWireSW”自定义用户模块。(FIXME: 如何？)
- 在“用户模块选择视图”中，选择您可能需要的“用户模块”：（您可以一次选择并放置一个，或选择所有模块，然后放置所有模块）。
- 数字通信：Uart（双击它以创建 UART_1）
- 温度：FlashTemp
- 三个“SAR6”模块 - 将它们重命名为“sar1”、“sar2”和“sar3”。
- 一个“OneWireSW”模块
- 一个 INSAMP - 将它重命名为“amp”。
- 在“互连视图”中，放置所有用户模块（右键单击每个模块并选择“放置”。（“已放置”的模块周围有一个粗彩色矩形。您尚未放置的模块周围没有矩形或只有细黑色矩形。）
- 在“应用程序编辑器”视图中，点击“构建”（F7）。
- 您应该收到消息“0 error(s) 0 warning(s)”。
- 将 psoc_forth.asm 源代码复制到一个名为 "psoc_forth.asm" 的文件中，与我们刚刚创建的 "main.asm" 文件位于同一目录中。
- 下载 "Algorithm - Unsigned Multiplication - AN2032" 由 Dave Van Ess 编写，并将文件“unsignedmath.inc”解压缩并放入与 "psoc_forth.asm" 相同的目录中
- （嗯...... “Algorithm - Signed Multi-Byte Multiplication - AN2038” 不会更好吗？）
- 在“应用程序编辑器”视图中，选择项目 | 添加到项目 | 文件... 并选择 "psoc_forth.asm"。
- 在“应用程序编辑器”视图中，点击“构建”（F7）。
- 您应该收到消息“0 error(s) 0 warning(s)”。(FIXME: ... 我从来没有完成过这一步 ...)
- 编辑源文件 "main.asm"，在 ".terminate" 之前添加以下行
jmp start ; start Forth interpreter
- 在“应用程序编辑器”视图中，点击“构建”（F7）以创建 hex 文件。
- 将微控制器上的串行端口连接到终端。（也许是上面使用的同一台 PC，运行一个终端模拟器；或者一个 PDA 串行端口，或者一个哑终端。）
- ...
; 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 safety 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, continuous 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
;-------------------------------------------------------------------------------------------------
; Interrupt 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
;--------------------------------------------------------------------------------------------------
separate:
rlc [W]
rlc [W]
mov a,1
separate0:
or [W+1],0
jz separate1
rlc a
dec [W+1]
jmp separate0
separate1:
mov [W+1],a
mov x,[W]
ret
Linput: head 5,'input',Lwend,0
input: pops W
call separate
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 separate
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 separate
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 separate
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 separate
mov a,reg[x]
or a,[W+1]
mov reg[x], a
next
Loff: head 3,'off',Lon,0
poff: pops W
call separate
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 separate
mov a, reg[x]
xor a, [W+1]
mov reg[x],a
next
Linp: head 3,'inp',Ltoggle,0
inp: pops W
call separate
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 separate
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 separate
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
Gus Calabrese 和 Bill Goodrich 做了一些细微的更改和注释，希望为更新的 PSOC（如我们的 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 safety 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, continuous 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 - pushes 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
;-------------------------------------------------------------------------------------------------
; Interrupt 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 approximation 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 approximation 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 approximation 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 replacing 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
;--------------------------------------------------------------------------------------------------
separate:
rlc [W]
rlc [W]
mov a,1
separate0:
or [W+1],0
jz separate1
rlc a
dec [W+1]
jmp separate0
separate1:
mov [W+1],a
mov x,[W]
ret
Linput: head 5,'input',Lwend,0
input: pops W
call separate
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 separate
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 separate
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 separate
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 separate
mov a,reg[x]
or a,[W+1]
mov reg[x], a
next
Loff: head 3,'off',Lon,0
poff: pops W
call separate
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 separate
mov a, reg[x]
xor a, [W+1]
mov reg[x],a
next
Linp: head 3,'inp',Ltoggle,0
inp: pops W
call separate
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 separate
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 separate
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
safetey: 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，这种技术对维基来说好吗？ - Bill
当然，很好。在我弄清楚你的更改意味着什么之后，我会编辑维基教科书：PSoC Forth，以便只显示一个版本 - 最新最好的版本。
这个最新版本是否仍然支持原始版本运行的所有芯片？（人们总是可以访问维基教科书：PSoC Forth 历史记录，查看原始版本或任何其他版本）。
"什么是 rp？返回指针？" 是的，它是指向“返回堆栈”顶部的指针。如果我们进行搜索和替换，将其重命名为“RSP”，使用与 Brad Rodríguez 和 FigUK 相同的术语：“The Heart of Forth” 文章，会不会更清晰？
现在对我来说最令人费解（的更改）是在一堆注释中添加“w” - 例如，我看到“;drop ( x -- ) drop TOS” 被更改为 “;w drop ( x -- ) drop TOS”。这个 “w” 对你来说意味着什么？
我发现试图将它适应更新的 466 芯片并不实际。我所能做的最好的就是让更新的芯片“模拟”Pforth，但这并没有什么用。最好从头开始。Chris Burns
- 2003：最初由 Christopher W. Burns 编写。
- 2006：维护工作由 David Cary 接手（从 版本 2.01 开始）。
- 2008 - 还有人对 PSOC Forth 感兴趣吗？Chris Burns
- 2008 - 我是唯一一个仍然对 PSoC Forth 感兴趣的人吗？-- DavidCary
20090208 No, David I am interested in supporting PSOC Forth. [email protected]
- 嵌入式系统/赛普拉斯 PSoC 微控制器 常见问题解答
- Gainer wiki 讨论了 GAINER，这是一个使用赛普拉斯 PSoC 创建用户界面和/或媒体装置的开源环境。
- M8Cutils for Linux
- PSoC Designer 的最新版本可以从 http://www.cypress.com/psocdesigner 下载。免费下载包含除 C 编译器以外的所有内容，对于本项目来说，我们不需要 C 编译器。