Forth/PSoC Forth

How to install PSoC Forth Ingredients: A PSoC microcontroller A PSoC flash-burner such as the ICE-Cube (it lets you debug, set breakpoints, single-step through your code, etc.) or the MiniProg (costs less). A PC that can run PSoC Designer for Windows or the M8Cutils for Linux. Create the hex file "psoc_forth.hex": either If you have a Windows box, use PSoC Designer (details below), or If you have a Linux box or a Macintosh, use M8Cutils. (Both development tools are free downloads.) Use the PSoC programmer to burn the hex file into the microcontroller. Creating the hex file with M8Cutils One-time install: Install the M8Cutils for Linux http://m8cutils.sourceforge.net/. Creating the hex file with PSoC designer 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 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 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 ; 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 Some slight changes and notes by Gus Calabrese and Bill Goodrich, in hopes of creating a workable version for newer PSOCs, like our CY8C29466. ; Kernel 16 bit forth for PSoC 27443 - 28 pin device ; Copyright 2003, Christopher W. Burns ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ; Modified 20070821 WFT Electronics wftElectronics.com ; b001 DHD ( Bill Goodrich ) and AGSC Denver, CO ; same licensing as above ; questions ????? ; What is rp? Return pointer? ;memory map include "m8c.inc" include "unsignedmath.inc" include "uart_1.inc" ; install UART can we install another UART ? b001 ; include "counter8_1.inc" include "sar1.asm" include "sar2.asm" include "sar3.asm" include "amp.asm" include "flashtemp_1.asm" include "flashtemp_1int.asm" include "onewiresw_1.asm" ;__________________________________________________________________________________ ;00| | ;10| | ;20| FLASH WRITE BUFFER | ;30|_______________________________________________________________________________| ;40| PARAMETER STACK | ;50| | ;60| | ;70| | ;80|_________RETURN STACK__________________________________________________________| ;90| | ;A0| | ;B0|_______________________________________________________________________________| ;C0|_cnt|TEXT INPUT BUFFER | ;D0|_______________________________________________________________________________| ;E0|___IP____|____W____|___HERE__|___LAST__|_CURRENT_|bloc|loc_|_rp_|base|_IN_|____| ;F0|_________|_________|_________|_________|___T0____|____T1___|___T2____|___T3____| IP: equ e0h W: equ e2h HERE: equ e4h LAST: equ e6h CURRENT:equ e8h bloc: equ eah loc: equ ebh rp: equ ech base: equ edh IN: equ eeh T0: equ f8H T1: equ fah T2: equ fch T3: equ feh sp0: equ 40h rp0: equ 90h cnt: equ c0h TIB: equ c1h EOT: equ e0h ;boot block structure mirrored in RAM vcurr: equ 0 vlast: equ 2 vhere: equ 4 vbase: equ 6 ;-------------------------------------------------------------------------------------- ; Macros ;-------------------------------------------------------------------------------------- macro next ljmp _next endm macro pushW ljmp _pushW endm macro incr inc [@0+1] adc [@0],0 endm macro colon lcall _colon endm macro doCon lcall _doCON endm macro fetch mov a, [IP] mov x, [IP+1] romx mov [@0], a incr IP endm macro pushs mov a,[@0] push a mov a, [@0+1] push a endm ;******************************************************************************** ; Pop the stack into a word register ;******************************************************************************** macro pops pop a ;1 mov [@0+1], a ;2 pop a ;1 mov [@0], a ;2 endm ;******************************************************************************** macro pushr mov x, [rp] dec x mov a, [@0] mov [x], a dec x mov a, [@0+1] mov [x], a mov [rp], x endm macro popr mvi a,[rp] mov [@0+1], a mvi a,[rp] mov [@0], a endm ; header structure ; <len><"name"><LINK address><flags>|CODE FIELD| macro head db @0 ds @1 dw @2 db @3 endm ;------------------------------------------------------------------------------------------------- area kernal16(rom,abs) org 540h send: M8C_DisableGInt push a send0: mov A, REG[UART_1_TX_CONTROL_REG] and a, 16 jz send0 pop a mov REG[UART_1_TX_INPUT_REG], a ret read_blk: mov [0f8h],3ah ;should be 3ah mov X,sp mov a,X add a,3 mov [0f9h],a ;sp+3 mov [0fah],[W+1] ;block id mov [0fbh], 0 ;buffer pointer mov [0fch],15 ;clock mov [fdh], 0 mov [feh], 0 mov [ffh], 0 mov a,01 SSC ;erase block nop nop nop ret blk_write: mov [0f8h],3ah ;should be 3ah mov X,sp mov a,X add a,3 mov [0f9h],a ;sp+3 mov [0fah],[W+1] ;block id mov [0fbh], 0 ;buffer pointer mov [0fch],15 ;clock mov [fdh], 0 mov [feh], 0 mov [ffh], 0 mov a,03 SSC ;erase block nop nop nop mov [0f8h],3ah ;should be 3ah mov X,sp mov a,X add a,3 mov [0f9h],a ;sp+3 mov [0fah],[W+1] ;block id mov [0fbh],0 ;buffer pointer mov [0fch],15 ;clock mov [fdh], 0 mov [feh], 0 mov [ffh], 0 mov a,02 SSC ;write block nop nop nop ret start:: mov a,sp0 swap a,sp ;initialize the stack mov [rp],rp0 ;initialize the return stack lcall OneWireSW_1_Start ;initialize one wire protocall ;******************************************************************************** ; Initialize the UART ;******************************************************************************** ; or reg[Counter8_1_CONTROL_REG],1 or REG[UART_1_TX_CONTROL_REG], 1 or REG[UART_1_RX_CONTROL_REG], 1 ;******************************************************************************** mov [IP],>FORTH mov [IP+1],<FORTH ;point to the main FORTH loop mov a, reg[8] ;check 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 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 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.