Forth/PSoC Forth
< Forth
How to install PSoC Forth
editIngredients:
- 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
editOne-time install:
- Install the M8Cutils for Linux http://m8cutils.sourceforge.net/.
Creating the hex file with PSoC designer
editUnfinished -- needs work
One-time install:
- Install PSoC Designer for Windows http://www.cypress.com/psocdesigner.
- 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 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
The source: alternate
editSome 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 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, 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.
Does this latest version still support all the chips that the original one ran on? (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 Rodríguez 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- Embedded Systems/Cypress PSoC Microcontroller FAQ
- Gainer wiki discusses GAINER, an open-source environment for creating user interfaces and/or media installations using the Cypress PSoC.
- M8Cutils for Linux
- The latest version of PSoC Designer can be downloaded from http://www.cypress.com/psocdesigner. The free download includes everything except the C compiler, which we won't need for this project.