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