TACHYON1V0-VGA
Table of Contents
Preface
Introduction Global CONstants... Used OBJects PUBlic Spin Methods Start Assembly Cog ByteCodes...
Reset and Exit
Internal Cog Routines... Stack Operators Arithmetic Boolean Comparision Memory Literals Fast Constants Variables I/O Access Cog Access Branch & Loop Stack Emit Registers Wait String Key
Bytecode Interpreter
High Level Forth Area... Literals Arithmetic Internal Stacks Data Stack Handler Loop Stack Handler Return Stack Handler Console Serial Output Cog Variables CONstants
CONstants
Dictionary in EEPROM... Allocate Memory High Level Bytecode Debug Print Routines Number Print Formatting Operators Loops Fills Cog SFR Registers Number Base Output Operations String to Number Compiler Extensions Console Input Handlers Main Console Terinal Version Bytecode Vector Table Extensions/Testings... Used OBJects Source... |
.:.:-- TACHYON --:.:.A very fast and very small Forth byte code interpreter for the Propeller chip. 2012 Peter Jakacki
Global CONstantsClock, Ports, Stack sizesSOURCE CODE... _clkmode = xtal1 + pll16x ' <---------------- change to suit _xinfreq = 5_000_000 ' <---------------- change to suit your crystal baud = 57600 ' tested to 3_000_000 baud, probably okay for 4M as well ' Port assignments scl = 28 sda = 29 txd = 30 rxd = 31 ' Stack sizes datsz = 12 retsz = 14 loopsz = 8 Global DATa for VideoSOURCE CODE... sync long 0 colors word 0[192] Global CONstants for VideoSOURCE CODE... Pixels = $2800 '$8000-(6144*4) Used OBJectsTachyon1v0-VGA.spin │ ├──HS-SerialRx.spin │ ├──VGA_512x384_Bitmap.spin ' missing │ └──endcode.spin SOURCE CODE... coms : "HS-SerialRx" ' Mega-baud serial receive driver vga : "VGA_512x384_Bitmap" endcode : "endcode" PUBlic Spin MethodsStart- Tachyon starts up in cog 1 - Serial receive starts up in cog 2 - vga starts up in cog 3 start returns and cog 0 ends - this Spin cog now terminates and is free for reuse as are cogs 4..7 SOURCE CODE... PUB Start cognew(@RESET, @MAIN) ' Tachyon starts up in cog 1 word[@rxbufptr] := coms.start(rxd, baud) ' Serial receive in cog 2 vga.start(16, @Colors, Pixels, @sync) word[@registers] := endcode.start ' Find where code ends ' this Spin cog now terminates and is free for reuse ' cog 0 free as are 4..7 Assembly CogTACHYON PASM KERNELSOURCE CODE... org $10 s ' just an offset to be used in DAT sections rather than the distracting +$10 ' ByteCodesByte tokens directly address code in the first 256 longs of the cog Rather than a jump table most functions are short or cascaded to optimize COG memory Larger fragments of code jump to the second half of the cog's memory. As a result of not using a jump table (there's not enough memory) there are gaps in the bytecode values and not all values are usable. The formatted source has bytecode labels as bold white on red background. Reset and ExitSOURCE CODE... org 0 RESET jmp #TACHYON ' As a result of being at location 0 this bytecode = 0 ' ( flg -- ) Exit if flg is true IFEXIT call #POPX tjnz X,#EXIT jmp #doNEXT ' ( flg -- ) Exit if flg is false (or zero) Used in place of IF......THEN EXIT as false would just end up exiting ZEXIT call #POPX tjnz X,#doNEXT EXIT call #_RPOPIP 'Pop top of return stack (discard) then cascade into NOP _NOP jmp #doNEXT Stack OperatorsSOURCE CODE... DROP3 call #POPX DROP2 call #POPX DROP call #POPX jmp #doNEXT ' ?DUP ( n1 -- n1 n1 | 0 ) DUP n1 if non-zero QDUP tjz tos,#doNext ' DUP ( n1 - n1 n1 ) Duplicate the top item on the stack DUP mov X,tos ' Read directly from the top of the data stack jmp #PUSHX ' Push X onto the data stack and doNEXT ' OVER ( n1 n2 -- n1 n2 n1 ) OVER mov X,tos+1 'read second data item and push jmp #PUSHX ' 3RD ( n1 n2 n3 -- n1 n2 n3 n1 ) Copy the 4th item onto the stack THIRD mov X,tos+2 ' read third data item jmp #PUSHX ' 4TH ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 ) Copy the 4th item onto the stack FOURTH mov X,tos+3 jmp #PUSHX ' NIP ( n1 n2 -- n2 ) Drop the second item (equiv: SWAP DROP) NIP mov tos+1,tos 'replace second item with top and drop jmp #DROP ' SWAP ( n1 n2 -- n2 n1 ) Swap the top two items SWAP mov X,tos+1 mov tos+1,tos jmp #PUTX ' ROT ( a b c -- b c a ) ROT mov X,tos+2 mov tos+2,tos+1 mov tos+1,tos ' Replace tos with X as new value PUTX mov tos,X jmp #doNEXT ArithmeticSOURCE CODE... PLUS movi _TWOOP,#%100000_001 ' + ( n1 n2 -- n3 ) jmp #TWOOP MINUS movi _TWOOP,#%100001_001 jmp #TWOOP ' 1+ ( n1 -- n1+1 ) INC add tos,#1 jmp #doNEXT ' 1- ( n1 -- n1-1 ) DEC sub tos,#1 jmp #doNEXT ' u/mod ( u1 u2 -- remainder quotient) both remainder and quotient are 32 bit unsigned numbers UDIVMOD call #_UDIVMOD jmp #doNEXT DIVIDE call #_UDIVMOD mov tos+1,tos jmp #DROP MULTIPLY call #_UMMUL jmp #DROP ' um* ( u1 u2 -- u1*u2L u1*u2H ) \ unsigned 32bit * 32bit -- 64bit result UMMUL call #_UMMUL ' UM* jmp #doNEXT NEGATE neg tos,tos jmp #doNEXT BooleanSOURCE CODE... INVERT neg X,#1 xor tos,X jmp #doNEXT _AND movi _TWOOP,#%011000_001 ' AND ( n1 n2 -- n3 ) jmp #TWOOP 'discard top of stack and execute modified PASM _ANDN movi _TWOOP,#%011001_001 ' ANDN ( n1 n2 -- n3 ) jmp #TWOOP _OR movi _TWOOP,#%011010_001 jmp #TWOOP _XOR movi _TWOOP,#%011011_001 jmp #TWOOP _SHR movi _TWOOP,#%001010_001 jmp #TWOOP _SHL movi _TWOOP,#%001011_001 jmp #TWOOP ' 2/ ( n1 -- n1 ) shift n1 right one bit (equiv to divide by 2) _SHR1 shr tos,#1 jmp #doNEXT ' 2* ( n1 -- n2 ) shift n1 left one bit (equiv to multiply by 2) _SHL1 shl tos,#1 jmp #doNEXT ' REV ( n1 bits -- n2 ) Reverse LSBs of n1 and zero-extend _REV movi _TWOOP,#%001111_001 jmp #TWOOP ' MASK ( bitpos -- bitmask ) MASK mov X,tos mov tos,#1 shl tos,X jmp #doNEXT ComparisionSOURCE CODE... ' 0= ( n1 -- flg ) true if n1 equals 0 ZEQ call #_ZEQ jmp #doNEXT ' = ( n1 n2 -- flg ) true if n1 is equal to n2 EQ cmp tos,tos+1 wz neg tos+1,#1 if_nz mov tos+1,#0 jmp #DROP ' > ( n1 n2 -- flg ) true if n1 > n2 GT cmps tos+1,tos wz,wc call #POPX if_a neg tos,#1 if_be mov tos,#0 jmp #doNEXT MemorySOURCE CODE... ' C@ ( caddr -- byte ) Fetch a byte from hub memory CFETCH rdbyte tos,tos jmp #doNEXT ' W@ ( waddr -- word ) Fetch a word from hub memory WFETCH rdword tos,tos jmp #doNEXT ' @ ( addr -- long ) Fetch a longfrom hub memory FETCH rdlong tos,tos jmp #doNEXT ' C+! ( n caddr -- ) add n to byte at hub addr CPLUSST rdbyte X,tos ' read in word from adress add tos+1,X ' add to contents of address - cascade ' C! ( n caddr -- ) store n to byte at addr CSTORE wrbyte tos+1,tos ' write the byte using address on the tos jmp #DROP2 ' W+! ( n waddr -- ) add n to word at hub addr WPLUSST rdword X,tos ' read in word from adress add tos+1,X ' W! ( n waddr -- ) store n to word at addr WSTORE wrword tos+1,tos jmp #DROP2 ' +! ( n addr -- ) add n to long at hub addr PLUSST rdlong X,tos ' read in long from adress add tos+1,X ' ! ( n addr -- ) store n to long at addr STORE wrlong tos+1,tos jmp #DROP2 ' C@++ ( addr -- caddr+1 byte ) fetch byte character and increment address CFETCHINC mov X,tos ' dup the address call #_PUSHX add tos+1,#1 ' inc the backup address jmp #CFETCH ' fetch at the current byte ' CMOVE ( src dst cnt -- ) Copy bytes from src to dst address for cnt bytes CMOVE jmp #_CMOVE ' PLOT ( x y -- ) Setup to plot 512x384 bitmap PLOT shl tos,#6 ' 64 bytes/Y line mov X,tos+1 shr tos+1,#3 ' byte offset in line add tos,tos+1 ' byte offset in frame add tos,pixeladr ' byte address in memory and X,#7 ' get bit mask mov tos+1,#1 shl tos+1,X ' SET ( mask caddr -- ) Set bit(s) in hub byte SET movi MEMINS,#%011010_001 ' or jmp #MEMOP ' CLR ( mask caddr -- ) Clear bit(s) in hub byte CLR movi MEMINS,#%011001_001 ' andn jmp #MEMOP ' SET? ( mask caddr -- flg ) Test single bit of byte in memory SETQ rdbyte X,tos and X,tos+1 wz SETNZ neg tos+1, #1 if_z mov tos+1,#0 jmp #DROP { ' C++ ( caddr -- ) Increment byte in hub memory CINC rdbyte X,tos add X,#1 wrbyte X,tos jmp #DROP } ' IC! ( byte -- byte ) dup & store byte using the loop index - used in FILL and ERASE ISTORE wrbyte tos,loopstk+1 jmp #doNEXT LiteralsSOURCE CODE... ' INLINE ( -- long ) Push a 32-bit literal onto the datastack by reading in the next 4 bytes (non-aligned) _LONG PUSH4 call #ACCBYTE ' read the next byte @IP++ and shift accumulate ' INLINE ( -- tribyte ) Push a 24-bit literal onto the datastack by reading in the next 3 bytes (non-aligned) PUSH3 call #ACCBYTE _WORD ' INLINE ( -- word ) Push a 16-bit literal onto the datastack by reading in the next 2 bytes (non-aligned) PUSH2 call #ACCBYTE ' INLINE ( -- byte ) Push an 8-bit literal onto the datastack by reading in the next byte _BYTE PUSH1 call #ACCBYTE PUSHACC call #_PUSHACC ' Push the accumulator onto the stack then zero it jmp #doNEXT { PUSHSTR mov X,IP jmp PUSHX } Fast ConstantsSOURCE CODE... ' Push a preset literal onto the stack using just one bytecode ' ' Use the "accumulator" to push the value which is built up by incrementing ' There is a minor penalty for the larger constants but it's still faster and more compact ' overall than using the PUSH1 method or the mov X,# method BL mov ACC,#$20-8 _8 add ACC,#1 _7 add ACC,#1 _6 add ACC,#1 _5 add ACC,#1 _4 add ACC,#1 _3 add ACC,#1 _2 add ACC,#1 _1 add ACC,#1 _FALSE _0 jmp #PUSHACC ' Push ACC and then zero ACC _TRUE MINUS1 neg X,#1 jmp #PUSHX VariablesSOURCE CODE... VARL ' Dummied out for the moment (not used at present) VARB { ' Variables start with this single byte code which returns with the address of the long aligned variable following VARL mov X,IP add X,#3 ' force long alignment andn X,#3 PUSHX_EXIT call #_PUSHX ' push address of variable jmp #EXIT ' Byte aligned variables start with this single byte code which returns with the address of the byte variable following ' INLINE: VARB mov X,IP jmp #PUSHX_EXIT ' Long aligned constant - created with CONSTANT and already aligned - CONSTANT XYZ %1001100011 CONL mov Y,IP add Y,#3 andn Y,#3 rdlong X,Y ' get constant call #_PUSHX jmp #EXIT CONSTANT byte _BYTE,CONL,XCALL,xBCOMP,REG,here,WFETCH,_3,PLUS,_3,_ANDN byte <get number>,SWAP,STORE,_4,REG,here,PLUSST,EXIT } I/O AccessSOURCE CODE... ' P@ ( -- n1 ) Read the input port A (assume it is always A for Prop 1) PFETCH mov X,INA jmp #PUSHX ' P! ( n1 -- ) Store n1 to the output port A PSTORE mov OUTA,tos jmp #DROP ' OUTSET ( mask -- ) Set multiple bits on the output OUTSET or OUTA,tos 'PSET ( mask -- ) \ Or mask to OUTA and make sure it's an output jmp #OUTPUTS ' OUTCLR ( mask -- ) Clear multiple bits on the output OUTCLR andn OUTA,tos 'PCLR ( mask -- ) ' OUTPUTS ( mask -- ) Set selected port pins to outputs OUTPUTS or DIRA,tos 'PDSET ( mask -- ) \ OR mask to DIRA jmp #DROP ' INPUTS ( mask -- ) Set selected port pins to inputs INPUTS andn DIRA,tos jmp #DROP ' OUT ( dat n1 -- dat/2 ) test lsb of data & set pinmask n1 to high or low - leave shifted dat on stack OUT shr tos+1,#1 wc muxc OUTA,tos jmp #DROP ' IN ( pin -- state ) Read in a single pin IN mov X,#1 shl X,tos test X,INA wz neg tos,#1 if_z mov tos,#0 jmp #doNEXT ' SPI style Clocked serial support CLKDAT jmp #_CLKDAT Cog AccessSOURCE CODE... ' COG@ ( addr -- long ) Fetch a long from cog memory COGFETCH movs _cf,tos nop _cf mov tos,0_0 jmp #doNEXT ' COG! ( long addr -- ) Store a long to cog memory COGSTORE movd _cd,tos nop _cd mov 0_0,tos+1 jmp #DROP2 '_REBOOT mov tos,#0 ' CLKSET op ' mov tos+1,#$0FF ' HUBOP ( val op -- result ) _HUBOP hubop tos+1,tos jmp #DROP ' STACKS ( -- cog_addr ) push address of internal stacks in cog memory STACKS mov X,#tos jmp #PUSHX ' Loop control words such as J K LEAVE etc implemented ' LSTACK ( -- cog_addr ) push address of the loop stack in cog memory LSTACK mov X,#loopstk jmp #PUSHX 'PASM ( code -- ) Load and execute PASM instruction ' Will look at executing from the data stack as an option ' This will allow small programs to be constructed and pushed one instruction at a ' time onto the stack - or possibly the loop stack PASMD jmp tos PASML jmp loopstk Branch & LoopSOURCE CODE... ' ACALL ( adr -- ) Call arbitrary address ACALL call #SAVEIP mov IP,tos jmp #DROP ' Perform a call to kernel bytecode via the XCALLS but reusing the high word of each vector ' The YCALLs will be implemented by the runtime compiler to extend the Xcode table YCALL '!!! mov Y,#2 '!!! jmp #xycall ' Perform a call to kernel bytecode via the XCALLS using the following inline byte as an index into that table XCALL mov Y,#0 xycall call #SETUPIP ' read offset in table shl X,#2 ' offset into longs in hub RAM add X,Xptr add X,Y rdword IP,X jmp #doNEXT ' Call a local defintion using 8-bit relative = 0 to -255 RCALL call #SETUPIP ' read next byte into X and save IP in return stack jmp #JMPBACK ' Call any bytecode definition using 16-bit relative addresses WCALL jmp #_WCALL ' Call any byte code definition using a 16-bit address { ' ( n1 n2 -- ) Compare two values and jump if equal. Equivalent to <> IF but clearer in Spin tool CMPJEQ cmp tos,tos+1 wz,wc call #POPX call #POPX if_ne jmp #SKIP } ' Jump forward by reading the next byte inline and adding that to the IP (at that point) JUMP _ELSE call #GETBYTE jmp #JMPFWD JNZ call #_ZEQ ' If flg is zero than jump forward by reading the next byte inline and adding that to the IP (at that point) ' IF R( flg -- ) JZ _IF movi zBRINS,#%100000_001 ' add jmp #zBRANCH JZBACK _UNTIL movi zBRINS,#%100001_001 ' sub jmp #zBRANCH JUMPBACK _AGAIN call #GETBYTE jmp #JMPBACK ' ADO = BOUNDS DO - just a quick and direct way as BOUNDS is most often never used elsewhere ' ADO ( from cnt -- ) ADO mov X,tos+1 add tos+1,tos mov tos,X ' DO ( to from -- ) DO jmp #_DO ' (+loop) ( n1 -- ) adds n1 to the loop index and branches back if not equal to the loop limit PLOOP add loopstk+1,tos wc call #POPX jmp #LOOPCHK LOOP add loopstk+1,#1 wc ' increment index, LOOPCHK cmps loopstk,loopstk+1 wz,wc if_ne jmp #_AGAIN call #_LPPOP SKIP1 call #_LPPOP SKIP add IP,#1 jmp #doNEXT ' FOR ( count -- ) Setup FOR...NEXT loop for count FOR call #_PUSHLP jmp #DROP ' NEXT ( -- ) Decrement count (on loop stack) and loop until 0, then pop loop stack forNEXT djnz loopstk,#JUMPBACK ' not done yet, jump backwards using branch jmp #SKIP1 ' complete, discard loop count and skip branch StackSOURCE CODE... ' >R ( n -- ) Push n onto the return stack PUSHR mov R0,tos call #_PUSHR jmp #DROP ' R> ( -- n ) Pop n from the return stack RPOP call #_RPOP ' Pop return stack into R and X jmp #PUSHX ' Push X onto the data stack as tos ' >L ( n -- ) Push n onto the loop stack PUSHL call #_PUSHLP jmp #DROP ' L> ( -- n ) Pop n from the loop stack LPOP call #_LPPOP ' Pop return stack into R and X jmp #PUSHX ' Push X onto the data stack as tos ' I ( -- index ) Read current loop index of DO..LOOP I mov X,loopstk+1 jmp #PUSHX EmitSOURCE CODE... ' EMIT ( char -- ) EMIT mov X,tos call #transmit jmp #DROP RegistersRegisters can be used just like variables and the interpreted kernel uses some for itself128 bytes are reserved which can be accessed as bytes/words/longs depending upon the alignment. SOURCE CODE... ' ( -- addr ) Read the next inline byte and return with the register byte address REG call #GETBYTE call #_PUSHX ' ( index -- addr ) Find the address of the register ATREG add tos,regptr jmp #doNEXT WaitSOURCE CODE... ' WAIT ( n -- ) Wait n clock cycles WAIT add tos,cnt waitcnt tos,tos jmp #DROP ' WAITCNT ( n -- n ) WAITCNTS waitcnt tos,tos jmp #doNEXT StringSOURCE CODE... ' Print a null terminated inline string PRTSTR jmp #_PRTSTR ' ' Compare a null-terminated source string with a dictionary string which is 8th bit terminated. ' This will always force a mismatch after which one is checked for a null while the other is checked ' for the 8th bit and if verified then a match has been found. ' The dict pointer is advanced to point to the end of the dict string on the 8th bit termination which ' is the attribute byte as in: byte "CMPSTR",$80,CMPSTR ' ' ' CMPSTR ( src dict -- src dict+ flg ) Compare strings at these two addresses CMPSTR jmp #_CMPSTR KeyThe read and write index is stored as two bytes preceding the buffer, read this as a word (faster)BKEY ( buffer -- ch ) ' byte size buffer is preceded with a read index, go and read the next character assume the buffer is 256 bytes long SOURCE CODE... BKEY mov X,tos sub X,#2 ' X Point to read (& write index) rdword Z,X mov Y,Z shr Y,#8 ' get read index Y and Z,#$0ff ' mask write index Z cmp Y,Z wz ' compare indicies if_z mov tos,#0 ' Return with a null value if_z jmp #doNEXT add tos,Z ' tos = read pointer rdbyte tos,tos or tos,#$100 ' and mark as valid (in case of nulls) add Z,#1 and Z,#$0ff ' wrap-around wrbyte Z,X ' update read index jmp #doNEXT Internal Cog RoutinesCode from here at cog address $100 on is not meant to be indexed by byte codes so therefore can be placed anywhere SOURCE CODE... regptr long @registers+s Xptr long @XCALLS+s ' used by XCALL fthptr long @MAIN+s pixeladr long pixels ' Reset Entry TACHYON mov IP,fthptr Bytecode InterpreterSOURCE CODE... ' Fetch the next byte code instruction in hub RAM pointed to by the instruction pointer IP ' doNEXT rdbyte token,IP 'read byte code instruction add IP,#1 'advance IP to next byte token jmp token 'execute the code ' common operations for two data items into one TWOOP call #POPX _TWOOP add tos,X wz,wc ' instruction here is modified by caller ' muxc status,#carry ' optional status flag update ' muxz status,#zero jmp #doNEXT MEMOP rdbyte X,tos MEMINS andn X,tos+1 wrbyte X,tos jmp #DROP2 ' Push IP>R, read 16-bit address relative +/- address into IP _WCALL call #GETBYTE mov Y,X call #SETUPIP shl X,#8 or X,Y JMPFWD add IP,X jmp #doNEXT JMPBACK sub IP,X jmp #doNEXT ' Read the next byte as a displacement and branch forward or backwards (BRINS modified by caller) zBRANCH call #GETBYTE 'read in next byte at IP and inc IP or tos,#0 wz 'test flag on stack zBRINS if_z add IP,X 'Adjust IP forward according to flag jmp #DROP 'discard flag _DO call #_PUSHLP ' PUSH index onto loop stack mov tos,tos+1 call #_PUSHLP ' push limit onto loop stack jmp #DROP2 _ZEQ or tos,#0 wz SETZ neg tos, #1 if_nz mov tos,#0 'force true to false SETZ_ret _ZEQ_ret ret LiteralsSOURCE CODE... ACCBYTE call #GETBYTE ' Build a literal by reading in another byte shl ACC,#8 ' merge it into the "accumulator" byte by byte or ACC,X ACCBYTE_ret ret GETBYTE rdbyte X,IP ' Simply read a byte (non-code) and advance the IP add IP,#1 GETBYTE_ret ret PUSHX call #_PUSHX ' Push the internal X register onto the datastack jmp #doNEXT ArithmeticSOURCE CODE... ' u/mod ( u1 u2 -- remainder quotient) both remainder and quotient are 32 bit unsigned numbers _UDIVMOD mov R1,#$20 mov R0,#0 ' quotient udivmodlp shl tos+1, #1 wc ' dividend rcl R0, #1 ' hi bit from dividend cmpsub R0, tos wc,wr ' cmp divisor rcl R2, #1 ' R2 - quotient djnz R1, #udivmodlp mov tos+1, R0 mov tos, R2 _UDIVMOD_ret ret ' um* ( u1 u2 -- u1*u2L u1*u2H ) \ unsigned 32bit * 32bit -- 64bit result _UMMUL cmp tos+1,tos wc ' try to go faster by using the lower number as the test factors if_nc mov R0,tos+1 if_nc mov R2,tos if_c mov R0,tos ' R0R1 = u2 if_c mov R2,tos+1 ' R2R3 = u1 mov R1,#0 mov tos,#0 ' zero result mov tos+1,#0 UMMULLP shr R2,#1 wz,wc ' test next bit of u1 if_nc jmp #UMMUL1 add tos+1,R0 wc ' add in shifted u2 addx tos,R1 ' carry into upper long UMMUL1 add R0,R0 wc ' shift u2 left addx R1,R1 ' carry into 64-bits if_nz jmp #UMMULLP ' exhausted u1? _UMMUL_ret ret ' Print inline string _PRTSTR rdbyte X,IP wz add IP,#1 if_z jmp #doNEXT call #transmit jmp #_PRTSTR _CMPSTR call #_PUSHX ' make room for a flag mov X,tos+2 ' X = source cmpstrlp rdbyte R0,X ' read in a character from the source rdbyte R1,tos+1 ' read in from the dictionary cmp R1,R0 wz ' are they the same? if_nz jmp #nomatch add X,#1 ' so far, so good, try next add tos+1,#1 ' updates the dict pointer on the stack too jmp #cmpstrlp ' keep at it nomatch cmp R0,#0 wz ' was the src null terminated? xor R1,#$80 if_z test R1,#$80 wz ' set z flag if dict 8th bit set call #SETZ jmp #doNEXT ' ' CMOVE ( src dst cnt -- ) _CMOVE rdbyte X,tos+2 ' read source byte add tos+2,#1 wrbyte X,tos+1 ' write destination byte add tos+1,#1 djnz tos,#_CMOVE jmp #DROP3 ' Clocks data from 1 to 32 bits at around 2.85MHz ' Use REV instruction to make data msb first (i.e. 24d REV 8 CLKDAT will send a byte MSB first) ' CLKDAT ( sdat scnt -- data ) ( L: miso mosi sck ) _CLKDAT andn OUTA,sck ' clock low test miso,INA wz ' test data from device while clock is low shr sdat,#1 wc ' assume lsb first (but i2c is msb first so rev ext) muxz sdat,msb ' shift input data into msb (justify ext) muxc OUTA,mosi ' send next bit of data out or OUTA,sck ' clock high djnz scnt,#_CLKDAT andn OUTA,sck ' leave with clock low jmp #DROP msb long $8000_0000 Internal Stacks' ' As well as the data and return stack, a loop stack is also employed ' The return stack should only used for return addresses ' Data Stack HandlerSOURCE CODE... ' Pop the data stack using fixed size stack in COG memory (allows fast direct access for operations) POPX mov X,tos ' pop old tos into X (temporary) mov tos,tos+1 mov tos+1,tos+2 mov tos+2,tos+3 mov tos+3,tos+4 mov tos+4,tos+5 mov tos+5,tos+6 mov tos+6,tos+7 mov tos+7,tos+8 mov tos+8,tos+9 mov tos+9,tos+10 mov tos+10,tos+11 mov tos+11,#0 ' zero fill for error checking POPX_ret ret _PUSHACC mov X,ACC mov ACC,#0 _PUSHX tjnz tos+11,#RESET ' check for overflow - zeros are don't care mov tos+11,tos+10 mov tos+10,tos+9 mov tos+9,tos+8 mov tos+8,tos+7 mov tos+7,tos+6 mov tos+6,tos+5 mov tos+5,tos+4 mov tos+4,tos+3 mov tos+3,tos+2 mov tos+2,tos+1 mov tos+1,tos mov tos,X ' replace tos with X (DEFAULT) _PUSHACC_ret _PUSHX_ret ret Loop Stack HandlerSOURCE CODE... _PUSHLP ' Push tos onto the loop stack mov loopstk+7,loopstk+6 mov loopstk+6,loopstk+5 mov loopstk+5,loopstk+4 mov loopstk+4,loopstk+3 mov loopstk+3,loopstk+2 mov loopstk+2,loopstk+1 mov loopstk+1,loopstk mov loopstk,tos _PUSHLP_ret ret _LPPOP ' pop the loop stack into X mov X,loopstk mov loopstk,loopstk+1 mov loopstk+1,loopstk+2 mov loopstk+2,loopstk+3 mov loopstk+3,loopstk+4 mov loopstk+4,loopstk+5 mov loopstk+5,loopstk+6 mov loopstk+6,loopstk+7 mov loopstk+7,#0 _LPPOP_ret ret Return Stack Handler' Return stack items do not need to be directly addressed ' This indexed method does not use movd and movs methods but directly inc/decs the ' source and destination fields of the instruction. SOURCE CODE... SETUPIP call #GETBYTE ' read the next byte into X and save the current IP SAVEIP mov R0,IP _PUSHR mov retstk,R0 ' save it on the stack (dest modified) add rpopins,#1 ' update source for popping add _PUSHR,dst1 ' update dest for pushing SETUPIP_ret SAVEIP_ret _PUSHR_ret ret ' RETURN STACK - pop into X _RPOPIP call #_RPOP mov IP,X _RPOPIP_ret ret _RPOP sub rpopins,#1 sub _PUSHR,dst1 rpopins mov X,retstk _RPOP_ret ret dst1 long $200 ' instruction's destination field increment Console Serial OutputSOURCE CODE... transmit or outa,txmask ' ensure output is high or dira,txmask ' make it an output or X,stopmask ' fill up with stop bits shl X,#1 ' add in start bit as first bit mov txcnt,#10 ' 8 data bits + 1 start + stop bits txdat mov R0,cnt add R0,bit_ticks txbit shr X,#1 wc ' lsb first muxc outa,txmask ' output bit waitcnt R0,bit_ticks djnz txcnt,#txbit 'another bit to transmit? transmit_ret ret bit_ticks long (80_000_000 / baud ) ' set baud rate txmask long |<txd stopmask long $FFFFFFFF<<8 txcnt res 1 Cog VariablesSOURCE CODE... token res 1 IP res 1 ' Instruction pointer ACC res 1 ' Accumulation register for inline byte-aligned literals R0 res 1 R1 res 1 R2 res 1 X res 1 'primary internal working registers Y res 1 ' Z res 1 tos datastk long 0[datsz] retstk long 0[retsz] loopstk long 0[loopsz] fit 496 ' Ensure we have enough room (BST reports free longs) CONstantsdefine some constants used by this cogThe CLKDAT parameters are defined here so that the method can be changed easily At present the data and cound are passed on the datastack while I/O masks are on the loopstack SOURCE CODE... org tos scnt res 1 sdat res 1 org loopstk sck res 1 mosi res 1 miso res 1 High Level Forth AreaCONstantsSOURCE CODE... carry = 1 zero = 2 numpadsz = 16 ' flags echo = 1 defining = $80 Allocate MemoryAllocate storage memory for buffers and other variablesSOURCE CODE... { REGISTERS } registers long 0[48] 'Variables used by kernel + general-purpose rxbufptr long 0 ' address saved from serial driver object org 0 ' register offsets within "registers". Access as REG,delim ... REG,base ... etc ' ' LONG aligned registers (can be used for bytes and words also) temp res 32 ' general purpose addr res 4 execloc res 4 ' use by EXECUTE to store bytecodes colorptr res 4 pixelptr res 4 anumber res 8 ' Assembled number from input digits res 1 ' number of digits in current number that has just been processed dpl res 1 ' Position of the decimal point if encountered (else zero) ' WORD aligned registers unum res 2 ' User number processing routine - executed if number failed and UNUM <> 0 rxptr res 2 ' Pointer to the terminal receive buffer - read & write index precedes uemit res 2 ukey res 2 res 2 names res 2 ' start of dictionary (builds down) prevname res 2 ' temp location used by CREATE res 2 here res 2 ' pointer to compilation area (overwrites VM image) codes res 2 ' current code comilation pointer (updates "here" or is reset by it) free res 2 ' Kernel reports where it stops and free memory for user begins cold res 2 errors res 2 ' Unaligned registers delim res 2 ' the delimiter used in text input and a save location base res 2 ' current number base + backup location during overrides spincnt res 1 ' Used by spinner to rotate busy symbol flags res 1 prefix res 1 ' NUMBER prefix suffix res 1 ' NUMBER suffix wordcnt res 1 ' length of current word (which is still null terminated) wordbuf res 32 ' words from the input stream are assembled here padwr res 1 ' write index (builds characters down from lsb to msb in MODULO style) numpad res numpadsz ' Number print format routines assemble digit characters here High Level Bytecode****** HIGH LEVEL BYTECODE DEFINITIONS ******Debug Print Routinesdebug print routines - also used by DUMP etcSOURCE CODE... ' .HEX ( n -- ) print nibble n as a hex character PRTHEX ' ( n -- ) print n (0..$0F) as a hex character byte _BYTE,$0F,_AND byte PUSH1,$30,PLUS byte DUP,PUSH1,$39,GT,_IF,@PRTCH-@PH1 PH1 byte _7,PLUS 'Adjust for A..F PRTCH byte EMIT,EXIT ' .BYTE ( n -- ) print n as 2 hex characters PRTBYTE byte DUP,_4,_SHR byte XCALL,xPRTHEX,XCALL,xPRTHEX,EXIT ' .WORD ( n -- ) print n as 4 hex characters PRTWORD byte DUP,_8,_SHR byte RCALL,@PW1-@PRTBYTE PW1 byte RCALL,@PW2-@PRTBYTE PW2 byte EXIT ' .LONG ( n -- ) print n as 8 hex characters PRTLONG byte DUP,PUSH1,16,_SHR byte RCALL,@PRL1-@PRTWORD PRL1 byte RCALL,@PRL2-@PRTWORD PRL2 byte EXIT ' DUMP ( addr cnt -- ) Hex dump of hub RAM - (NOTE: if CFETCH is vectored then other memory can be accessed) DUMP byte ADO DML byte XCALL,xCR byte I,XCALL,xPRTWORD byte PRTSTR,": ",0 byte I,PUSH1,$10,ADO DM0 byte I,CFETCH,XCALL,xPRTBYTE byte PUSH1,$20,EMIT,LOOP,@DM2-@DM0 DM2 byte PRTSTR," ",0 byte I,PUSH1,$10,ADO dm6 byte I,CFETCH,DUP,BL,XCALL,xLT,OVER,PUSH1,$7E,GT,_OR byte _IF,03,DROP,PUSH1,"." byte EMIT,LOOP,@dm5-@dm6 dm5 byte PUSH1,$10,PLOOP,@DM3-@DML DM3 byte XCALL,xCR,EXIT ' COGDUMP ( addr cnt -- ) Dump cog memory, but try to minimize stack usage COGDUMP byte REG,temp,WSTORE,REG,temp+2,WSTORE,JUMP,@cdm2-@cdmlp cdmlp byte REG,temp+2,WFETCH,_3,_AND,ZEQ,_IF,@cdm3-@cdm2 cdm2 byte XCALL,xCR,REG,temp+2,WFETCH,XCALL,xPRTWORD,PRTSTR,": ",0 cdm3 byte REG,temp+2,WFETCH,COGFETCH,XCALL,xPRTLONG,BL,EMIT byte _1,REG,temp+2,WPLUSST,MINUS1,REG,temp,WPLUSST byte REG,temp,WFETCH,ZEQ,_UNTIL,@cdm1-@cdmlp cdm1 byte EXIT ' .S Print out the top four numbers of the datastack PRTSTK byte PRTSTR,$0D,$0A,"STACK: ",0 byte FOURTH,XCALL,xPRTLONG,BL,EMIT byte THIRD,XCALL,xPRTLONG,BL,EMIT byte OVER,XCALL,xPRTLONG,BL,EMIT byte DUP,XCALL,xPRTLONG,BL,EMIT byte EXIT PRTSTKS ' Print stacks but avoid cluttering with data from debug routines byte STACKS,PUSH1,datsz byte PRTSTR,$0D,$0A,"DATA STACK ",0 byte XCALL,xCOGDUMP byte STACKS,PUSH1,datsz,PLUS,PUSH1,retsz byte PRTSTR,$0D,$0A,"RETURN STACK ",0 byte XCALL,xCOGDUMP byte STACKS,PUSH1,datsz+retsz,PLUS,PUSH1,loopsz byte PRTSTR,$0D,$0A,"LOOP STACK ",0 byte XCALL,xCOGDUMP byte EXIT ' Print the stack(s) and dump the registers - also called by hitting <ctrl>D during text input DEBUG byte XCALL,xPRTSTKS byte PRTSTR,$0D,$0A,"REGISTERS",0 byte REG,temp,PUSH1,$80,XCALL,xDUMP byte PRTSTR,$0D,$0A,"COMPILATION AREA",0 byte REG,here,WFETCH,PUSH1,$40,XCALL,xDUMP byte EXIT CNTFETCH ' CNT@ ( addr -- data ) byte PUSH2,$01,$F1,COGFETCH,EXIT _REBOOT ' REBOOT byte _BYTE,$FF,_0,_HUBOP,DROP,EXIT STOP ' STOP ( cog -- ) byte _3,_HUBOP,DROP,EXIT _COGID ' COGID ( -- id ) byte MINUS1,_1,_HUBOP,EXIT ' HERE ( -- addr ) Address of next compilation location _HERE byte REG,here,WFETCH,EXIT ' ITEM ( index -- regaddr ) ITEM byte _SHL1,_SHL1,ATREG,EXIT ' ITEM@ ( index -- long ) ITEMFT byte XCALL,xITEM,FETCH,EXIT ' ITEMS ( n1..nx cnt -- ) Push n stack items into registes ITEMS byte _0,DO,I,XCALL,xITEM,STORE,LOOP,06,EXIT Number Print FormattingSOURCE CODE... ' @PAD ( -- addr ) pointer to current position in number pad ATPAD byte REG,padwr,CFETCH,REG,numpad,PLUS,EXIT AddPAD byte MINUS1,REG,padwr,CPLUSST,XCALL,xATPAD,CSTORE,EXIT ' >CHAR ( val -- ch ) convert binary value to an ASCII character TOCHAR byte PUSH1,$3F,_AND,PUSH1,"0",PLUS,DUP,PUSH1,"9" ' convert to "0".."9" byte GT,_IF,02,_7,PLUS ' convert to "A".. byte DUP,PUSH1,$5D,GT,ZEXIT,_3,PLUS,EXIT ' skip symbols to go to "a".. ' #> ( n1 -- caddr ) RHASH byte DROP,XCALL,xATPAD,EXIT ' <# ' resets number pad write index to end of pad LHASH byte PUSH1,numpadsz,REG,padwr,CSTORE,_0,XCALL,xAddPAD,EXIT ' # ( n1 -- n2 ) convert the next ls digit to a char and prepend to number string HASH byte REG,base,CFETCH,UDIVMOD,SWAP,XCALL,xtoCHAR,XCALL,xAddPAD,EXIT ' #S ( n1 -- 0 ) Convert all digits HASHS byte XCALL,xHASH,DUP,ZEQ,_UNTIL,06,EXIT STRLEN ' ( str -- len ) byte DUP,CFETCHINC,ZEQ,_UNTIL,4,SWAP,MINUS,DEC,EXIT ' STR ( -- n ) Leave address of inline string on stack and skip to next instruction _STR byte RPOP,DUP STRlp byte CFETCHINC,ZEQ,_UNTIL,04,PUSHR,EXIT ' .STR ( adr -- ) Print the null or 8th bit terminated string PSTR byte CFETCHINC,DUP,ZEQ,OVER,_BYTE,$7F,GT,_OR,_IF,02,DROP2,EXIT,EMIT,_AGAIN,15 ' U. ( n -- ) Print an unsigned number UPRT byte XCALL,xLHASH,XCALL,xHASHS,XCALL,xRHASH byte XCALL,xPSTR,BL,EMIT,EXIT ' . ( n -- ) Print the number off the stack PRT byte DUP,XCALL,xZLT,_IF,04,PUSH1,$2D,EMIT,NEGATE,XCALL,xUPRT,EXIT ' .. ( n base -- ) Print the number off the stack in the base specified basePRT byte REG,base,CFETCH,PUSHL,REG,base,CSTORE,XCALL,xPRT byte LPOP,REG,base,CSTORE,EXIT OperatorsSOURCE CODE... ' MIN ( n1 n2 -- n3 ) signed minumum of two items _MIN byte OVER,OVER,GT,_IF,02,NIP,EXIT,DROP,EXIT ' MAX ( n1 n2 -- n3 ) signed maximum of two items _MAX byte OVER,OVER,GT,_IF,02,DROP,EXIT,NIP,EXIT ' 0<> ( n1 -- flg ) true if n1 is not equal to 0 ZNE byte ZEQ,ZEQ,EXIT ' <> ( n1 n2 -- flg ) true if n1 is not equal to n2 NEQ byte EQ,ZEQ,EXIT ' 0> ( n -- flg ) true if greater than zero (signed) ZGT byte _0,GT,EXIT ' 0< ( n -- flg ) ZLT byte _0,XCALL,xLT,EXIT ' < ( n1 n2 -- flg ) LT byte SWAP,GT,EXIT ' U< ULT byte OVER,OVER,_XOR,XCALL,xZLT,_IF,04 byte NIP,XCALL,xZLT,EXIT byte MINUS,XCALL,xZLT,EXIT ' ( n lo hi -- flg ) true if n is within range of low and high inclusive WITHIN byte INC,OVER,MINUS,PUSHR byte MINUS,RPOP,XCALL,xULT WT1 byte XCALL,xZNE,EXIT ' KEY? ( -- ch flg ) KEYQ byte REG,rxptr,WFETCH,WFETCH,BKEY,DUP,_BYTE,$0FF,_AND,SWAP,_8,_SHR,EXIT KEY byte REG,rxptr,WFETCH,WFETCH,BKEY,QDUP,_UNTIL,@ky1-@KEY ky1 byte _BYTE,$0FF,_AND,EXIT ' \ ( -- ) ' Ignore following text till the end of line. ' IMMED COMMENT byte XCALL,xKEY,_BYTE,$0D,EQ,_UNTIL,07,EXIT BRACE byte XCALL,xKEY,_BYTE,")",EQ,_UNTIL,07,EXIT CURLY byte XCALL,xKEY,_BYTE,"}",EQ,_UNTIL,07,EXIT LoopsSOURCE CODE... ' BOUNDS ( from for -- to from ) BOUNDS byte OVER,PLUS,SWAP,EXIT LEAVE byte LSTACK,COGFETCH,LSTACK,INC,COGSTORE,EXIT ' set index to the same as limit ' Index of next outer loop J byte LSTACK,_3,PLUS,COGFETCH,EXIT ' set index to the same as limit ' Index of third loop K byte LSTACK,_5,PLUS,COGFETCH,EXIT ' set index to the same as limit ' Fetch index of FOR..NEXT loop (or the limit for a DO..LOOP) IX byte LSTACK,COGFETCH,EXIT ' set index to the same as limit FillsSOURCE CODE... ERASE byte _0 'FILL ' ( addr cnt fillch -- ) FILL byte ROT,ROT,ADO,ISTORE,LOOP,3,DROP,EXIT ' ms ( n -- ) Wait for n milliseconds ms byte PUSH3,$01,$38,$80,MULTIPLY,WAIT,EXIT Cog SFR RegistersSOURCE CODE... _PAR byte _WORD,$01,$F0,EXIT _CNT byte _WORD,$01,$F1,EXIT _INA byte _WORD,$01,$F2,EXIT _INB byte _WORD,$01,$F3,EXIT _OUTA byte _WORD,$01,$F4,EXIT _OUTB byte _WORD,$01,$F5,EXIT _DIRA byte _WORD,$01,$F6,EXIT _DIRB byte _WORD,$01,$F7,EXIT _CTRA byte _WORD,$01,$F8,EXIT _CTRB byte _WORD,$01,$F9,EXIT _FRQA byte _WORD,$01,$FA,EXIT _FRQB byte _WORD,$01,$FB,EXIT _PHSA byte _WORD,$01,$FC,EXIT _PHSB byte _WORD,$01,$FD,EXIT _VCFG byte _WORD,$01,$FE,EXIT _VSCL byte _WORD,$01,$FF,EXIT _SFR byte _WORD,$01,$F0,PLUS,EXIT InitStack byte DROP3,DROP3,DROP3,DROP3 ' clean up the data stack (won't hurt) byte PUSH4,$A5,$5A,$A5,$5A ' check value (JUST FOR TESTING) byte exit Number Basechange the default number basesSOURCE CODE... BIN byte _2,JUMP,@SetBase-@DECIMAL DECIMAL byte PUSH1,10,JUMP,@SetBase-@HEX HEX byte PUSH1,16 SetBase byte REG,BASE,CSTORE,EXIT Output OperationsSOURCE CODE... CLS byte PUSH1,$0C,EMIT,EXIT SPACE byte BL,EMIT,EXIT BELL byte _7,EMIT,EXIT CR byte PUSH1,$0D,EMIT,PUSH1,$0A,EMIT,EXIT ' : SPINNER 19d @REG C@ 3 SHR 3 AND " |/-\" + C@ EMIT 8 EMIT 1 19d @REG C+! 1 ms ; SPINNER byte REG,spincnt,CFETCH,_3,_SHR,_3,_AND,XCALL,x_STR,"|/-\",0,PLUS,CFETCH byte EMIT,_8,EMIT,_1,REG,spincnt,CPLUSST,_1,XCALL,xms,EXIT ' PROMPT OK byte PRTSTR," ok",$0D,$0A,0,EXIT ' ?EMIT ,( ch -- ch ) suppress emitting the character if echo flag is off QEMIT byte _BYTE,echo,REG,flags,SETQ,ZEXIT,DUP,EMIT,EXIT ' >UPPER ( str1 -- ) Convert lower-case letters to upper-case TULP byte INC TOUPPER byte DUP,CFETCH,QDUP,_IF,@TUX-@TU1 ' end of string? TU1 byte _BYTE,"a",_BYTE,"z",XCALL,xWITHIN byte _UNTIL,@TU2-@TULP TU2 byte _BYTE,-$20,OVER,CPLUSST,_AGAIN,@TUX-@TULP TUX byte DROP,EXIT String to Number****** STRING TO NUMBER CONVERSION ******SOURCE CODE... ' functional test for now - optimize later ' Convert ASCII value as a digit to a numeric value - only interested in bases up to 16 at present ' TODIGIT ' ( char -- val true | false ) byte DUP,PUSH1,"0",PUSH1,"9",XCALL,xWITHIN,_IF,@td8-@td7 ' only work with 0..9,A..F td7 byte PUSH1,"0",MINUS,_TRUE,EXIT ' pass decimal digits td8 byte DUP,PUSH1,"A",PUSH1,"F",XCALL,xWITHIN,_IF,@td2-@td1 td1 byte PUSH1,$37,MINUS,_TRUE,EXIT ' pass hex digits td2 byte DROP,_FALSE,EXIT { Try to convert a string to a number Allow all kinds of symbols but these are the rules for it to be treated as a number. 1. Leading character must be either a recognized prefix or a decimal digit 2. If trailing character is a recognized suffix then the first character must be a decimal digit Acceptable forms are: $1000 hex number 1000h #1000 decimal number 1000d %1000 binary number 1000b Also as long as the first character and last character are valid then any symbols me be mixed in the number i.e. 11:59 11.59 #5_000_000 } _NUMBER ' ( str -- value digits | false ) byte DUP,CFETCH,REG,prefix,CSTORE ' save prefix (it may or nmay not be) byte DUP,DEC,CFETCH,DEC,OVER,PLUS,CFETCH,REG,suffix,CSTORE ' save suffix (assume string has count byte) ' PREFIX HANDLER byte DUP,CFETCH ' check prefix ' ( str ch ) byte _FALSE byte OVER,PUSH1,"$",EQ,_IF,04,XCALL,xHEX,_TRUE,_OR ' as does $ - also set hex base byte OVER,PUSH1,"%",EQ,_IF,04,XCALL,xBIN,_TRUE,_OR ' as does % - also set binary base byte OVER,PUSH1,"#",EQ,_IF,04,XCALL,xDECIMAL,_TRUE,_OR ' as does # - also set decimal base byte DUP,_IF,04,ROT,INC,ROT,ROT ' adjust string pointer to skip prefix ' ( str ch flg ) byte SWAP,PUSH1,"0",PUSH1,"9",XCALL,xWITHIN,_OR ' 0..9 forces processing as a number ' ( str flg ) byte ZEQ,_IF,03,DROP,_FALSE,EXIT ' Give up now, it isn't a candiate ' ( str ) ' so far, so good, now check suffix ' SUFFIX HANDLER byte REG,suffix,CFETCH byte DUP,PUSH1,"0",PUSH1,"9",XCALL,xWITHIN ' 0..9 byte OVER,PUSH1,"A",PUSH1,"F",XCALL,xWITHIN,_OR ' A..F ( str sfx flg ) true if still a digit byte OVER,PUSH1,"h",EQ,_IF,04,XCALL,xHEX,_TRUE,_OR ' h = HEX byte OVER,PUSH1,"b",EQ,_IF,04,XCALL,xBIN,_TRUE,_OR ' b = BINARY byte SWAP,PUSH1,"d",EQ,_IF,04,XCALL,xDECIMAL,_TRUE,_OR ' d = DECIMAL byte ZEQ,_IF,03,DROP,_FALSE,EXIT ' bad suffix, no good ' so far the prefix and suffx have been checked prior to attempt a number conversion ' From here on there must be at least one valid digit for a number to be accepted ' DIGIT EXTRACTION & ACCUMULATION nmlp byte DUP,CFETCH,DUP,_IF,@nmend-@nm1 ' while there is another character nm1 byte XCALL,xTODIGIT,_IF,@nmsym-@nm2 ' convert to a digit? or else check symbol nm2 ' a digit has been found but is it valid for this base? ' ( str val ) byte DUP,REG,BASE,CFETCH,DEC,GT,_IF,@nmok-@nm3 nm3 byte DROP2,_FALSE,EXIT ' a digit but exceeded base nmok byte REG,anumber,FETCH,REG,BASE,CFETCH,MULTIPLY ' shift anumber left one digit (base) byte PLUS,REG,anumber,STORE ' and merge in new digit byte _1,REG,digits,CPLUSST ' update number of digits nmnxt byte INC,_AGAIN,@nmsym-@nmlp ' update str and loop ' character was not a digit - check for valid symbols (keep it simple for now) ' SYMBOLS nmsym byte DUP,PUSH1,"_",XCALL,xNEQ,JZ,@nm4-@nmnxt ' ignore if "_" nm4 byte JUMPBACK,@nmend-@nmnxt ' in fact just ignore symbols for now nmend ' end of string - check byte DROP2,REG,digits,CFETCH,DUP,ZEXIT ' return with false if there are no digits byte REG,anumber,FETCH,SWAP,EXIT ' all good, return with number and true NUMBER ' ( str -- value digits | false ) byte DUP,XCALL,xSTRLEN,_2,EQ byte OVER,CFETCH,_BYTE,"^",EQ,_AND,_IF,@ch01-@ctlch ' ^ch Accept caret char as <control> char ctlch byte CFETCH,_BYTE,$1F,_AND,_1,EXIT ch01 byte DUP,XCALL,xSTRLEN,_3,EQ byte OVER,CFETCH,_BYTE,$22,EQ,_AND,_IF,@ch02-@ascch ' "ch" Accept as an ASCII literal ascch byte INC,CFETCH,_1,EXIT ' It wasn't a ASCII literal, process as a number ch02 byte REG,anumber,PUSH1,10,XCALL,xERASE ' zero out assembled number (double), digits, dpl byte REG,BASE,CFETCH,REG,base+1,CSTORE ' backup current number as it may be overridden byte RCALL,@nmb1-@_NUMBER nmb1 byte REG,base+1,CFETCH,REG,BASE,CSTORE,EXIT ' restore default base before returning Compiler ExtensionsMost of these words are acted upon immediately rather than compiled as they arepart of the "compiler" in that they create the necessary structures SOURCE CODE... ' dumb compiler for literals - improve later - just needs to optimize the number of bytes needed LITCOMP ' ( n -- ) compile the literal according to size byte DUP,PUSH1,24,_SHR byte _IF,@lco1-@LITC4 ' Compile 4 bytes - 32bits LITC4 byte PUSH1,PUSH4,XCALL,xBCOMP byte DUP,PUSH1,24,_SHR,XCALL,xBCOMP byte DUP,PUSH1,16,_SHR,XCALL,xBCOMP byte DUP,_8,_SHR,XCALL,xBCOMP byte XCALL,xBCOMP,EXIT lco1 byte DUP,PUSH1,16,_SHR byte _IF,@lco2-@LITC3 ' Compile 3 bytes - 24bits LITC3 byte PUSH1,PUSH3,XCALL,xBCOMP byte DUP,PUSH1,16,_SHR,XCALL,xBCOMP byte DUP,_8,_SHR,XCALL,xBCOMP byte XCALL,xBCOMP,EXIT lco2 byte DUP,_8,_SHR byte _IF,@LITC1-@LITC2 ' Compile 2 bytes - 16bits LITC2 byte PUSH1,PUSH2,XCALL,xBCOMP byte DUP,_8,_SHR,XCALL,xBCOMP byte XCALL,xBCOMP,EXIT ' Compile 1 byte - 8bits LITC1 byte PUSH1,PUSH1,XCALL,xBCOMP byte XCALL,xBCOMP,EXIT BCOMP ' ( bytecode -- ) append this bytecode to next free code location + append EXIT (without counting) byte REG,codes,WFETCH,CSTORE,_1,REG,codes,WPLUSST byte _BYTE,EXIT,REG,codes,WFETCH,CSTORE byte EXIT BCOMPILE ' ( atradr -- ) compile bytecodes according to attribute byte CFETCHINC,_3,_AND byte DUP,ZEQ,_IF,05,DROP,CFETCH,XCALL,xBCOMP,EXIT byte DUP,_2,EQ,_IF,08,DROP,CFETCHINC,XCALL,xBCOMP,CFETCH,XCALL,xBCOMP,EXIT byte DROP2,EXIT ' MARKER ( addr tag -- tag&addr ) Merge tag and addr by shifting tag into hi word MARKER byte _BYTE,$10,_SHL,_OR,EXIT ' UNMARK ( tag&addr -- addr tag ) UNMARK byte DUP,_WORD,$FF,$FF,_AND,SWAP,_BYTE,$10,_SHR,EXIT ' FOR ( cnt -- ) Compile the runtime FOR word and mark the current postion for NEXT to branch to _FOR_ byte _BYTE,FOR,XCALL,xBCOMP,REG,codes,WFETCH,_BYTE,$F0,RCALL,@fo01-@MARKER fo01 byte EXIT ' NEXT ( -- ) Compile the runtime forNEXT word and resolve the branch _NEXT_ byte RCALL,@nx00-@UNMARK nx00 byte _BYTE,$F0,EQ,_IF,@badthen-@nx01 nx01 byte _BYTE,forNEXT,JUMP,@lpcalc-@nx02 nx02 ' ' DO ( to from -- ) Compile the runtime DO word and mark the current postion for LOOP to branch to _DO_ byte _BYTE,DO,JUMP,@markdo-@_ADO_ ' ADO ( from for -- ) Compile the runtime ADO word and mark the current postion for LOOP to branch to _ADO_ byte _BYTE,ADO markdo byte xCALL,xBCOMP,REG,codes,WFETCH,_BYTE,$D0,RCALL,@mkd1-@MARKER ' leave branch addr and token $D0 on stack mkd1 byte EXIT _LOOP_ byte RCALL,@lp00-@UNMARK lp00 byte _BYTE,$D0,EQ,_IF,@badthen-@lp01 ' Does this match with a DO? lp01 byte _BYTE,LOOP,JUMP,@lpcalc-@lp02 ' sure does, compile a LOOP lp02 ''' _PLOOP_ byte RCALL,@plp00-@UNMARK plp00 byte _BYTE,$D0,EQ,_IF,@badthen-@plp01 ' Does this match with a DO? plp01 byte _BYTE,PLOOP,JUMP,@lpcalc-@plp02 ' sure does, compile a LOOP plp02 ''' ' BEGIN as in BEGIN...AGAIN or BEGIN...UNTIL _BEGIN_ byte REG,codes,WFETCH,_BYTE,$BE,RCALL,@bg01-@MARKER ' generate markers for BEGIN bg01 byte EXIT ' UNTIL ( flg -- ) _UNTIL_ byte RCALL,@unt00-@UNMARK unt00 byte _BYTE,$BE,EQ,_IF,@badthen-@unt01 unt01 byte _BYTE,_UNTIL,XCALL,xBCOMP,JUMP,@calcback-@_REPEAT_ ' ' AGAIN _REPEAT_ byte RCALL,@rp00-@UNMARK rp00 byte _BYTE,$1F,EQ,_IF,@badrep-@rp02 rp02 byte REG,codes,WFETCH,INC,INC,OVER,MINUS,SWAP,DEC,CSTORE ' process branch of WHILE to after REPEAT byte JUMP,@_AGAIN_-@badrep badrep byte DROP2,JUMP,@badthen-@_AGAIN_ _AGAIN_ byte RCALL,@ag00-@UNMARK ag00 byte _BYTE,$BE,EQ,_IF,@badthen-@ag01 ' ag01 byte _BYTE,_AGAIN ' ( addr bc -- ) compile the bytecode and calculate the branch back lpcalc byte XCALL,xBCOMP calcback byte REG,codes,WFETCH,INC,SWAP,MINUS,XCALL,xBCOMP byte EXIT ' IF as in IF...THEN or IF...ELSE...THEN _WHILE_ _IF_ byte _BYTE,_IF,XCALL,xBCOMP,_0,XCALL,xBCOMP byte REG,codes,WFETCH,_BYTE,$1F,RCALL,@if01-@MARKER if01 byte EXIT ' ELSE _ELSE_ byte RCALL,@el00-@UNMARK el00 byte _BYTE,$1F,EQ,_IF,@badthen-@el01 ' does this match an IF? el01 byte _BYTE,JUMP,XCALL,xBCOMP,_0,XCALL,xBCOMP ' Compile a jump forward just like an IF byte REG,codes,WFETCH,_BYTE,$1F,RCALL,@el02-@MARKER ' mark the else to be processed on a THEN el02 byte SWAP,_BYTE,$1F,RCALL,@el03-@MARKER ' get the IF addr and proceed as if it were a THEN el03 ' THEN _THEN_ byte RCALL,@th00-@UNMARK th00 byte _BYTE,$1F,EQ,_IF,@badthen-@th01 th01 byte REG,codes,WFETCH,OVER,MINUS,SWAP,DEC,CSTORE,EXIT ' calculate branch and update IF's branch badthen byte PRTSTR," Structure mismatch! ",0 byte DROP,EXIT ' " Compile a literal string - no length restriction - any codes can be included except the delimiter " _STR_ byte _BYTE,XCALL,XCALL,xBCOMP,_BYTE,x_STR,XCALL,xBCOMP ' compile bytecodes for string byte JUMP,@COMPSTR-@_PSTR_ ' ." Compile a literal print string - no length restriction - any codes can be included except the delimiter " _PSTR_ byte _BYTE,PRTSTR,XCALL,xBCOMP COMPSTR pslp byte XCALL,xKEY,DUP,EMIT byte DUP,_BYTE,$22,EQ,_IF,05,DROP,_0,XCALL,xBCOMP,EXIT byte XCALL,xBCOMP,_AGAIN,@ps01-@pslp ps01 ''' ' XCALLS ( -- addr ) address of XCALLS _XCALLS byte _WORD,(@XCALLS+s)>>8,@XCALLS+s,EXIT ' +XCALL ( addr -- index ) Add an entry to the XCALL vector table AddXCALL byte _WORD,(@XCALLS+s)>>8,@XCALLS+s ' ( addr xcodeptr ) axlp byte _4,PLUS,DUP,WFETCH,ZEQ,_UNTIL,@axrdy-@axlp ' scan for an enpty entry axrdy byte SWAP,OVER,STORE ' save the entry ( addr ) byte _WORD,(@XCALLS+s)>>8,@XCALLS+s,MINUS,_SHR1,_SHR1 ' Calculate the index byte EXIT ' Create a new entry in the dictionary and also in the XCALLS table but also prevent any execution of code ' at an <enter> which would otherwise normally occur. ' : <name> COLON byte XCALL,xCREATE,REG,codes,WFETCH,XCALL,xAddXCALL ' Add an entry to the Xcode table - returns with index byte REG,names+2,WFETCH,DEC ' to 2nd bytecode of the header ( index addr ) byte CSTORE ' this forms an XCALL,index to this new definition byte _BYTE,defining,REG,flags,SET,EXIT ' Update "here" pointer to point to current free position which "codes" pointer is now at ' Also unsmudge the headers tag ' ; ENDCOLON byte _BYTE,EXIT,XCALL,xBCOMP,REG,codes,WFETCH,REG,here,WSTORE byte _BYTE,defining,REG,flags,CLR,EXIT ' CREATE <name> create a name in the dictionary CREATE byte REG,names,DUP,WFETCH,SWAP,INC,INC,WSTORE ' backup names ptr (used to change fixed fields easily) byte XCALL,xGETWORD,PUSH1,hd+sm+xc,XCALL,xPUTCHARPL ' add attribute byte (with smudge bit set) byte PUSH1,XCALL,XCALL,xPUTCHARPL byte PUSH1,xDEBUG,XCALL,xPUTCHARPL ' add a default bytecode sequence byte REG,wordcnt,DUP,INC,SWAP,CFETCH ' ( str cnt ) byte DUP,NEGATE,REG,names,WPLUSST ' ( str cnt ) update names ptr byte REG,names,WFETCH,SWAP,CMOVE byte EXIT Console Input HandlersReplacing traditional parse function with realtime stream parsing Each word is acted upon when a delimiter is encountered and this also allows for interactive error checking and even autocompletion.SOURCE CODE... ' ( ch -- ) write a character into the next free position in the word buffer PUTCHAR byte REG,wordcnt,DUP,CFETCH,SWAP,INC,PLUS,CSTORE,EXIT PUTCHARPL byte XCALL,xPUTCHAR,_1,REG,wordcnt,CPLUSST,EXIT ' As characters are accepted from the input stream, checks need to be made for delimiters, ' editing commands etc. doCHAR ' ( char -- flg ) Process char into wordbuf and flag true if all done byte DUP,ZEXIT ' NULL - ignore ' byte _3,OVER,EQ,_IF,02,XCALL,xREBOOT ' ^C RESET byte _4,OVER,EQ,_IF,05,DROP,XCALL,xDEBUG,_FALSE,EXIT ' ^D DEBUG byte _BYTE,$1B,OVER,EQ,_IF,@doc2-@doc1 ' ESC will cancel line doc1 byte REG,here,WFETCH,REG,codes,WSTORE byte _0,REG,wordcnt,CSTORE,_0,REG,wordbuf,CSTORE byte _BYTE,$0D,REG,delim+1,CSTORE byte _BYTE,$0D,EMIT,_BYTE,$40,FOR,_BYTE,"-",EMIT,forNEXT,05 byte DROP,_TRUE,EXIT ' doc2 byte PUSH1,$09,OVER,EQ,_IF,02,EMIT,BL ' TAB - substitute with a space byte PUSH1,$0D,OVER,EQ,_IF,@dc1-@cr1 ' CR cr1 byte REG,delim+1,CSTORE,_TRUE,EXIT ' CR - Return & indicate completion ' dc1 byte _8,OVER,EQ,_IF,@tk2-@bksp1 ' BKSP - null out last char bksp1 byte REG,wordcnt,CFETCH,_IF,@bksp3-@bksp2 ' don't backspace on empty word bksp2 byte EMIT,BL,EMIT,_8,EMIT byte MINUS1,REG,wordcnt,CPLUSST,_0,XCALL,xPUTCHAR ' null previous char byte _FALSE,EXIT ' ' bksp3 byte _7,EMIT,DROP,_FALSE,EXIT ' can't backspace anymore, bell ' tk2 byte PUSH1,$0A,OVER,EQ,_IF,03,DROP,_FALSE,EXIT ' LF - discard ' byte REG,delim,CFETCH,OVER,EQ,_IF,@tk5-@adelim ' delimiter? adelim byte DUP,REG,delim+1,CSTORE ' remember which delimter did this byte EMIT,REG,wordcnt,CFETCH,EXIT ' true if trailing delimiter - all done ' tk5 ' otherwise build text in wordbuf - null terminated with a preceding count ..... byte DUP,EMIT,XCALL,xPUTCHARPL ' put a character into the word buffer byte _FALSE,EXIT ' Build a delimited word and return immediately upon a valid delimiter GETWORD ' ( -- ) Build a text word from character input into wordbuf for wordcnt byte REG,wordcnt,PUSH1,33,XCALL,xERASE 'Erase the word buffer & preceding count gwlp byte XCALL,xKEY byte XCALL,xdoCHAR byte _UNTIL,@gw1-@gwlp 'continue building the next word gw1 byte EXIT ' ( src -- atrptr | false ) Try to find the string in the dictionary using CMPSTR to help FINDSTR byte REG,names,WFETCH ' from dictionary start fstlp byte CMPSTR ' ( src dict+ flg ) byte _IF,@nxtword-@fst1 ' found it fst1 ' ( src dict ) byte NIP,EXIT ' ( atrptr ) found ' Skip the attribute byte and codes and test for end of dictionary (entry = 00) nxtword ' ( src dict ) advance past atr+codes to try next. (atr(1),bytecode) nwlp byte CFETCHINC,PUSH1,$80,_AND,_UNTIL,@nw1-@nwlp nw1 byte INC,INC,DUP,CFETCH,ZEQ,_UNTIL,@fst2-@fstlp fst2 byte DROP2,_FALSE,EXIT TICK byte XCALL,xGETWORD,REG,wordbuf,XCALL,xFINDSTR,EXIT EXECUTE ' ( bytecode1 bytecode2 -- ) byte REG,execloc+1,CSTORE,REG,execloc,CSTORE byte PUSH1,EXIT,REG,execloc+2,CSTORE 'byte REG,execloc,BL,XCALL,xDUMP byte xCALL,xEXEC,EXIT DISCARD dslp byte XCALL,xKEYQ,_AND,ZEQ,_UNTIL,@ds01-@dslp ds01 byte _BYTE,100,XCALL,xms,XCALL,xKEYQ,_AND,ZEQ,_UNTIL,@ds02-@dslp ds02 byte EXIT Main Console Terinalapply this label to the main startup wordSOURCE CODE... MAIN TERMINAL byte XCALL,xInitStack byte PUSH1,200,XCALL,xms ' a little startup delay (also wait for serial cog) byte _BYTE,echo,REG,flags,CSTORE ' echo flag byte BL,REG,delim,CSTORE,XCALL,xHEX ' default delimiter byte REG,cold,WFETCH,_WORD,$A5,$5A,XCALL,xNEQ ' performing a check for a saved session byte _IF,@warmst-@coldst ' or it is coldst byte REG,0,WFETCH,DUP,REG,free,WSTORE,REG,here,WSTORE byte _WORD,(@rxbufptr+s)>>8,@rxbufptr+s,REG,rxptr,WSTORE ' setup saved receive buffer address 'byte _WORD,(@RESET+s)>>8,@RESET+s,REG,here,WSTORE ' Use VM hub image for code byte _WORD,(@dictionary+2)>>8,@dictionary+s,REG,names,WSTORE ' Reset dictionary pointer byte _WORD,$A5,$5A,REG,cold,WSTORE ' VGA byte _WORD,(@colors+s)>>8,@colors+s,REG,colorptr,STORE ' init pointers to VGA colors and pixels byte _WORD,Pixels>>8,Pixels,REG,pixelptr,STORE warmst byte PRTSTR,$0C,00,XCALL,xVER ' VERSION termcr byte REG,here,WFETCH,REG,codes,WSTORE ' reset temporary code compilation pointer 'byte PRTSTR,"_",0 ' subdued prompt termlp byte XCALL,xGETWORD ' Read a word from input stream etc byte REG,wordbuf,CFETCH,ZEQ,_IF,@trm1-@trm2 ' ignore empty string trm2 byte REG,delim+1,CFETCH,_BYTE,$0D,EQ,JNZ,@chkeol-@trm1 trm1 byte REG,wordbuf,XCALL,xFINDSTR ' try and find that word in the dictionary byte QDUP,_IF,@notfound-@foundword ' found it foundword ' found the word in the dictionary - compile or execute? byte PUSH1,im,OVER,SETQ,_IF,@compword-@immed immed byte INC,CFETCHINC,SWAP,CFETCH,XCALL,xEXECUTE ' Fetch and execute code immediately byte _ELSE,@chkeol-@compword compword byte XCALL,xBCOMPILE ' or else compile the bytecode(s) for ths word ' END OF LINE CHECK chkeol byte REG,delim+1,CFETCH,PUSH1,$0D,EQ ' Was this the end of line? byte DUP,_IF,02,BL,EMIT ' Yes, put a space between any user input and response byte DUP,_BYTE,defining,REG,flags,SETQ,_AND ' and are we in a definition or interactive? byte _IF,02,XCALL,xCR ' If not interactive then CRLF (no other response) byte _BYTE,defining,REG,flags,SETQ,ZEQ,_AND ' do not execute if still defining byte _UNTIL,@execs-@termlp ' wait until CR to execute compiled codes ' EXECUTE CODE from user input execs byte PUSH1,EXIT,XCALL,xBCOMP ' done - append an EXIT (minimum action on empty lines) byte REG,here,WFETCH,ACALL ' execute from beginning byte XCALL,xOK byte _AGAIN,@notfound-@termcr notfound ' NOT FOUND - before converting to a number check encoding for ^ and " byte REG,wordbuf,XCALL,xNUMBER,_IF,@unknown-@compnum compnum byte XCALL,xLITCOMP byte _AGAIN,@unknown-@termlp ' is it a number? ( value digits ) unknown byte REG,unum,WFETCH,QDUP,_IF,03,ACALL,_AGAIN,@un01-@termlp un01 byte BL,EMIT,REG,wordbuf,XCALL,xPSTR byte PRTSTR," NOT FOUND!!! ",7,0 byte _1,REG,errors,WPLUSST ' count errors since “TACHYON” byte RCALL,@un02-@DISCARD un02 byte _AGAIN,@trmend-@termlp trmend ' NFA>CFA ( nfa -- cfa ) BEGIN C@++ $7F > UNTIL ; NFACFA byte CFETCHINC,_BYTE,$7F,GT,_UNTIL,06,EXIT WORDS byte REG,names,WFETCH wdlp byte XCALL,xCR,DUP,XCALL,xPRTWORD,PRTSTR,": ",0 byte DUP,XCALL,xNFACFA,DEC,DUP,_3,ADO wdlp1 byte I,CFETCH,XCALL,xPRTBYTE,BL,EMIT,LOOP,@wd01-@wdlp1 wd01 byte _3,PLUS,SWAP,XCALL,xPSTR,BL,EMIT byte DUP,CFETCH,ZEQ,_UNTIL,@wd02-@wdlp wd02 byte DROP,XCALL,xCR,EXIT ' END Place at end of source code file to display stats from when TACHYON was invoked _END byte PRTSTR,$0D,$0A,"End of source code, there were ",0 byte REG,errors,WFETCH,_BYTE,10,XCALL,xbasePRT,PRTSTR," errors found ",0 byte PRTSTR,$0D,$0A,"CODE @ ",0,REG,here,WFETCH,DUP,XCALL,xPRTWORD byte REG,here-2,WFETCH,MINUS,PRTSTR," - bytes used in this load = ",0 byte _BYTE,10,XCALL,xbasePRT byte PRTSTR,$0D,$0A,"NAMES @ ",0,REG,names,WFETCH,DUP,XCALL,xPRTWORD byte REG,names-2,WFETCH,SWAP,MINUS,PRTSTR," - bytes used in this load = ",0 byte _BYTE,10,XCALL,xbasePRT byte PRTSTR,$0D,$0A,"XCALLS @ ",0,_0,XCALL,xAddXCALL,_BYTE,$FF,SWAP,MINUS byte _BYTE,10,XCALL,xbasePRT byte PRTSTR,"entries free (not including YCALLS)",0 byte EXIT _TACHYON byte XCALL,xVER byte REG,here,WFETCH,REG,here-2,WSTORE byte REG,names,WFETCH,REG,names-2,WSTORE byte EXIT Version<ctrl>D invokes a DEBUG action to dump stacks and registers <ctrl>C will reboot (only in text input) <BREAK> will always reboot as the serial driver acts directly on this condition To do: Multitasking via cogs - start them all at reset but only run MAIN on the first one, others idle ESC - cancel input line DONE Add CONSTANT constructs for fast constant access CURRENT KNOWN BUGS: LOOP limits are not detected when crossed, only when equal SOURCE CODE... VER byte PRTSTR,$0D,$0A,$0D,$0A byte " Propeller .:.:--TACHYON--:.:. Forth V1.0 rev120731.1700 " byte $0D,$0A,0 byte _0,REG,errors,WSTORE,EXIT Bytecode Vector Table****** BYTECODE DEFINITIONS VECTOR TABLE ****** Kernel bytecode definitions need to be called and this table makes it easy to do so with just a 2 byte call. Extra memory may be allocated for user definitions as well The Spin compiler requires longs whereas we only need 16-bit words but this will do at present. The runtime compiler can reuse the high-word of all these longs and compile a YCALL rather than an XCALL so that the high-word is used instead SOURCE CODE... org 0 ' ensure references can be reduced to a single byte index to be called by XCALL xx ' XCALLS xXCALLS long @_XCALLS+s xEXEC long @registers+execloc+s xMIN long @_MIN+s xMAX long @_MAX+s xNEQ long @NEQ+s xZNE long @ZNE+s xLT long @LT+s xZLT long @ZLT+s xZGT long @ZGT+s xULT long @ULT+s xWITHIN long @WITHIN+s xMS long @ms+s xCNTFETCH long @CNTFETCH+s xBOUNDS long @BOUNDS+s xLEAVE long @LEAVE+s xJ long @J+s xK long @K+s xIX long @IX+s xInitStack long @InitStack+s xCOMMENT long @COMMENT+s xBRACE long @BRACE+s xCURLY long @CURLY+s xPRTHEX long @PRTHEX+s xPRTBYTE long @PRTBYTE+s xPRTWORD long @PRTWORD+s xPRTLONG long @PRTLONG+s xPRTSTK long @PRTSTK+s xPRTSTKS long @PRTSTKS+s xDEBUG long @DEBUG+s xDUMP long @DUMP+s xCOGDUMP long @COGDUMP+s xREBOOT long @_REBOOT+s xSTOP long @STOP+s xCOGID long @_COGID+s x_PAR long @_PAR+s x_CNT long @_CNT+s x_INA long @_INA+s x_INB long @_INB+s x_OUTA long @_OUTA+s x_OUTB long @_OUTB+s x_DIRA long @_DIRA+s x_DIRB long @_DIRB+s x_CTRA long @_CTRA+s x_CTRB long @_CTRB+s x_FRQA long @_FRQA+s x_FRQB long @_FRQB+s x_PHSA long @_PHSA+s x_PHSB long @_PHSB+s x_VCFG long @_VCFG+s x_VSCL long @_VSCL+s x_SFR long @_SFR+s xCLS long @CLS+s xSPACE long @SPACE+s xBELL long @BELL+s xCR long @CR+s xOK long @OK+s xSPINNER long @SPINNER+s xBIN long @BIN+s xDECIMAL long @DECIMAL+s xHEX long @HEX+s xKEYQ long @KEYQ+s xKEY long @KEY+s xQEMIT long @QEMIT+s xTOUPPER long @TOUPPER+s xPUTCHAR long @PUTCHAR+s xPUTCHARPL long @PUTCHARPL+s xdoCHAR long @doCHAR+s xGETWORD long @GETWORD+s xTICK long @TICK+s xFINDSTR long @FINDSTR+s xEXECUTE long @EXECUTE+s xVER long @VER+s xFILL long @FILL+s xERASE long @ERASE+s xCMOVE long @CMOVE+s xTODIGIT long @TODIGIT+s xNUMBER long @NUMBER+s xTERMINAL long @TERMINAL+s xATPAD long @ATPAD+s xAddPAD long @AddPAD+s xTOCHAR long @TOCHAR+s xRHASH long @RHASH+s xLHASH long @LHASH+s xHASH long @HASH+s xHASHS long @HASHS+s x_STR long @_STR+s xPSTR long @PSTR+s xSTRLEN long @STRLEN+s xUPRT long @UPRT+s xPRT long @PRT+s xbasePRT long @basePRT+s xLITCOMP long @LITCOMP+s xBCOMP long @BCOMP+s xBCOMPILE long @BCOMPILE+s x_STR_ long @_STR_+s x_PSTR_ long @_PSTR_+s x_FOR_ long @_FOR_+s x_NEXT_ long @_NEXT_+s x_DO_ long @_DO_+s x_ADO_ long @_ADO_+s x_LOOP_ long @_LOOP_+s x_PLOOP_ long @_PLOOP_+s x_IF_ long @_IF_+s x_ELSE_ long @_ELSE_+s x_THEN_ long @_THEN_+s x_BEGIN_ long @_BEGIN_+s x_UNTIL_ long @_UNTIL_+s x_AGAIN_ long @_AGAIN_+s x_REPEAT_ long @_REPEAT_+s xCOLON long @COLON+s xENDCOLON long @ENDCOLON+s xCREATE long @CREATE+s xAddXCALL long @AddXCALL+s xHERE long @_HERE+s xITEM long @ITEM+s xITEMFT long @ITEMFT+s xITEMS long @ITEMS+s xNFACFA long @NFACFA+s xWORDS long @WORDS+s x_TACHYON long @_TACHYON+s xEND long @_END+s ' NOTE: this table is limited to 256 entires but leave room for extensions and user application to use the rest of these xLAST long 0[255-xLAST] ' Reserve the rest of the area possible long 0 Dictionary in EEPROMAlthough this dictionary is loaded into RAM automatically by the Prop bootloader it is not used by TACHYON and is free to be used for other purposes. Instead, the copy of the dictionary that is in EEPROM is searched and this is also where new names are appended to. * Revision: As the image of the cog program's DAT section in RAM can be reused after boot then this would be a good place to copy the kernel's dictionary from where it is in RAM so it can reuse up some 2KB. Now the kernel's dictionary can be searched in RAM rather than EEPROM! There should be enough room left for another 200 or so entries. Search methods: Structure: 1- Name string 2- Attribute byte (8th bit set also terminates name string ) 3- 1st bytecode, 2nd bytecode Dictionary entries do not need a link field as they are bunched together one after another and it is very easy to find the next entry by scanning forwards and looking for the attribute byte which will have the msb set then jumping 3 bytes. A name field that begins with a null indicates end of dictionary (or link to another) Dictionary CONstantsSOURCE CODE... ' Dictionary header attribute flags hd = |<7 ' indicates this is a an attribute (delimits the start of a null terminated name) co = |<6 'lexicon compile only bit im = |<5 'lexicon immediate bit ex = |<4 'exec sm = |<3 ' rl = |<2 ' code attributes 00 = single bytecode, 02 = XCALL bytecode (2 bytes), 03 = WCALL bytecode (3 bytes) xc = |<1 'XCALL bytecode ac = xc+|<0 'WCALL - 2 byte address Dictionary DATaThis is an 8th bit terminated string using the attribute byte so it saves one byte per entry plus it may simplfy the string compare function. Searching still proceeds from lower memory to higher memorySOURCE CODE... { This is an 8th bit terminated string using the attribute byte so it saves one byte per entry plus it may simplfy the string compare function. Searching still proceeds from lower memory to higher memory} { ****** DICTIONARY ****** } byte $FF[1000] dictionary ' NAME ATR CODES byte "RESET", hd, RESET,EXIT byte "?EXIT", hd, IFEXIT,EXIT byte "0EXIT", hd, ZEXIT,EXIT byte "EXIT", hd, EXIT,EXIT byte "NOP", hd, _NOP,EXIT byte "3DROP", hd, DROP3,EXIT byte "2DROP", hd, DROP2,EXIT byte "DROP", hd, DROP,EXIT byte "?DUP", hd, QDUP,EXIT byte "DUP", hd, DUP,EXIT byte "OVER", hd, OVER,EXIT byte "3RD", hd, THIRD,EXIT byte "4TH", hd, FOURTH,EXIT byte "SWAP", hd, SWAP,EXIT byte "ROT", hd, ROT,EXIT byte "NIP", hd, NIP,EXIT byte "1+", hd, INC,EXIT byte "1-", hd, DEC,EXIT byte "+", hd, PLUS,EXIT byte "-", hd, MINUS,EXIT byte "*", hd, MULTIPLY,EXIT byte "/", hd, DIVIDE,EXIT byte "U/MOD", hd, UDIVMOD,EXIT byte "UM*", hd, UMMUL,EXIT byte "NEGATE", hd, NEGATE,EXIT byte "INVERT", hd, INVERT,EXIT byte "AND", hd, _AND,EXIT byte "ANDN", hd, _ANDN,EXIT byte "OR", hd, _OR,EXIT byte "XOR", hd, _XOR,EXIT byte "SHR", hd, _SHR,EXIT byte "SHL", hd, _SHL,EXIT byte "2/", hd, _SHR1,EXIT byte "2*", hd, _SHL1,EXIT byte "REV", hd, _REV,EXIT byte "MASK", hd, MASK,EXIT byte "0=", hd, ZEQ,EXIT byte "=", hd, EQ,EXIT byte ">", hd, GT,EXIT byte "C@", hd, CFETCH,EXIT byte "W@", hd, WFETCH,EXIT byte "@", hd, FETCH,EXIT byte "C+!", hd, CPLUSST,EXIT byte "C!", hd, CSTORE,EXIT byte "C@++", hd, CFETCHINC,EXIT byte "W+!", hd, WPLUSST,EXIT byte "W!", hd, WSTORE,EXIT byte "+!", hd, PLUSST,EXIT byte "!", hd, STORE,EXIT byte "CMOVE", hd, CMOVE,EXIT byte "SET", hd, SET,EXIT byte "CLR", hd, CLR,EXIT byte "SET?", hd, SETQ,EXIT 'byte "C++", hd, CINC,EXIT byte "IC!", hd, ISTORE,EXIT byte "PUSH4", hd, PUSH4,EXIT byte "PUSH3", hd, PUSH3,EXIT byte "PUSH2", hd, PUSH2,EXIT byte "PUSH1", hd, PUSH1,EXIT byte "LVAR", hd, VARL,EXIT byte "BVAR", hd, VARB,EXIT byte "FALSE", hd, _0,EXIT byte "OFF", hd, _0,EXIT byte "0", hd, _0,EXIT byte "1", hd, _1,EXIT byte "2", hd, _2,EXIT byte "3", hd, _3,EXIT byte "4", hd, _4,EXIT byte "5", hd, _5,EXIT byte "6", hd, _6,EXIT byte "7", hd, _7,EXIT byte "8", hd, _8,EXIT byte "ON", hd, MINUS1,EXIT byte "TRUE", hd, MINUS1,EXIT byte "-1", hd, MINUS1,EXIT byte "BL", hd, BL,EXIT byte "LSTACK", hd, LSTACK,EXIT byte "EMIT", hd, EMIT,EXIT byte "P@", hd, PFETCH,EXIT byte "P!", hd, PSTORE,EXIT byte "OUTSET", hd, OUTSET,EXIT byte "OUTCLR", hd, OUTCLR,EXIT byte "OUTPUTS", hd, OUTPUTS,EXIT byte "INPUTS", hd, INPUTS,EXIT byte "OUT", hd, OUT,EXIT byte "IN", hd, IN,EXIT byte "CLKDAT", hd, CLKDAT,EXIT byte "COG@", hd, COGFETCH,EXIT byte "COG!", hd, COGSTORE,EXIT byte "HUBOP", hd, _HUBOP,EXIT byte "STACKS", hd, STACKS,EXIT byte "LSTACK", hd, LSTACK,EXIT byte "CALL", hd, ACALL,EXIT byte "(XCALL)", hd, XCALL,EXIT byte "(RCALL)", hd, RCALL,EXIT byte "(WCALL)", hd, WCALL,EXIT ' byte "(CMPJEQ)", hd, CMPJEQ,EXIT byte "(ELSE)", hd, _ELSE,EXIT byte "(IF)", hd, _IF,EXIT byte "(UNTIL)", hd, _UNTIL,EXIT byte "(AGAIN)", hd, _AGAIN,EXIT byte "(ADO)", hd, ADO,EXIT byte "(DO)", hd, DO,EXIT byte "(LOOP)", hd, LOOP,EXIT byte "(+LOOP)", hd, PLOOP,EXIT byte "(FOR)", hd, FOR,EXIT byte "(NEXT)", hd, forNEXT,EXIT byte ">R", hd, PUSHR,EXIT byte "R>", hd, RPOP,EXIT byte ">L", hd, PUSHL,EXIT byte "L>", hd, LPOP,EXIT byte "I", hd, I,EXIT byte "BKEY", hd, BKEY,EXIT byte "EMIT", hd, EMIT,EXIT byte "(REG)", hd, REG,EXIT byte "@REG", hd, ATREG,EXIT byte "WAIT", hd, WAIT,EXIT byte "WAITCNT", hd, WAITCNTS,EXIT byte "(PTRSTR)", hd, PRTSTR,EXIT byte "(CMPSTR)", hd, CMPSTR,EXIT byte "PASMD", hd, PASMD,EXIT byte "PASML", hd, PASML,EXIT byte "PLOT", hd, PLOT,EXIT { INTERPRETED BYTECODE HEADERS } byte "XCALLS", hd+xc, XCALL,xXCALLS byte "REBOOT", hd+xc, XCALL,xREBOOT byte "STOP", hd+xc, XCALL,xSTOP byte "COGID", hd+xc, XCALL,xCOGID byte "PAR", hd+xc, XCALL,x_PAR byte "CNT", hd+xc, XCALL,x_CNT byte "INA", hd+xc, XCALL,x_INA byte "INB", hd+xc, XCALL,x_INB byte "OUTA", hd+xc, XCALL,x_OUTA byte "OUTB", hd+xc, XCALL,x_OUTB byte "DIRA", hd+xc, XCALL,x_DIRA byte "DIRB", hd+xc, XCALL,x_DIRB byte "CTRA", hd+xc, XCALL,x_CTRA byte "CTRB", hd+xc, XCALL,x_CTRB byte "FRQA", hd+xc, XCALL,x_FRQA byte "FRQB", hd+xc, XCALL,x_FRQB byte "PHSA", hd+xc, XCALL,x_PHSA byte "PHSB", hd+xc, XCALL,x_PHSB byte "VCFG", hd+xc, XCALL,x_VCFG byte "VSCL", hd+xc, XCALL,x_VSCL byte "SFR", hd+xc, XCALL,x_SFR byte "2+", hd+xc, _2,PLUS byte "2-", hd+xc, _2,MINUS byte "2DUP", hd+xc, OVER,OVER byte "MIN", hd+xc, XCALL,xMIN byte "MAX", hd+xc, XCALL,xMAX byte "0<>", hd+xc, XCALL,xZNE byte "<>", hd+xc, XCALL,xNEQ byte "0>", hd+xc, XCALL,xZGT byte "0<", hd+xc, XCALL,xZLT byte "<", hd+xc, XCALL,xLT byte "U<", hd+xc, XCALL,xULT byte "WITHIN", hd+xc, XCALL,xWITHIN byte "BOUNDS", hd+xc, XCALL,xBOUNDS byte "LEAVE", hd+xc, XCALL,xLEAVE byte "J", hd+xc, XCALL,xJ byte "K", hd+xc, XCALL,xK byte "IX", hd+xc, XCALL,xIX byte "ERASE", hd+xc, XCALL,xERASE byte "FILL", hd+xc, XCALL,xFILL byte "ms", hd+xc, XCALL,xms byte "CNT@", hd+xc, XCALL,xCNTFETCH byte "KEY?", hd+xc, XCALL,xKEYQ byte "KEY", hd+xc, XCALL,xKEY byte "HEX", hd+xc, XCALL,xHEX byte "DECIMAL", hd+xc, XCALL,xDECIMAL byte "BINARY", hd+xc, XCALL,xBIN byte ".S", hd+xc, XCALL,xPRTSTK byte "DUMP", hd+xc, XCALL,xDUMP byte "COGDUMP", hd+xc, XCALL,xCOGDUMP byte ".STACKS", hd+xc, XCALL,xPRTSTKS byte "DEBUG", hd+xc, XCALL,xDEBUG byte "CLS", hd+xc, XCALL,xCLS byte "SPACE", hd+xc, XCALL,xSPACE byte "BELL", hd+xc, XCALL,xBELL byte "CR", hd+xc, XCALL,xCR byte "SPINNER", hd+xc, XCALL,xSPINNER byte ".HEX", hd+xc, XCALL,xPRTHEX byte ".BYTE", hd+xc, XCALL,xPRTBYTE byte ".WORD", hd+xc, XCALL,xPRTWORD byte ".LONG", hd+xc, XCALL,xPRTLONG byte ".", hd+xc, XCALL,xPRT byte ">DIGIT", hd+xc, XCALL,xTODIGIT byte "NUMBER", hd+xc, XCALL,xNUMBER byte "GETWORD", hd+xc, XCALL,xGETWORD byte "FINDSTR", hd+xc, XCALL,xFINDSTR byte "VER", hd+xc, XCALL,xVER byte "TACHYON", hd+xc, XCALL,x_TACHYON byte "@PAD", hd+xc, XCALL,xATPAD byte "+PAD", hd+xc, XCALL,xAddPAD byte ">CHAR", hd+xc, XCALL,xTOCHAR byte "#>", hd+xc, XCALL,xRHASH byte "<#", hd+xc, XCALL,xLHASH byte "#", hd+xc, XCALL,xHASH byte "#S", hd+xc, XCALL,xHASHS byte "(STR)", hd+xc, XCALL,x_STR byte ".STR", hd+xc, XCALL,xPSTR byte "STRLEN", hd+xc, XCALL,xSTRLEN byte "U.", hd+xc, XCALL,xUPRT byte "B.", hd+xc, XCALL,xbasePRT byte "colors", hd+xc, REG,colorptr byte "pixels", hd+xc, REG,pixelptr byte "REG", hd+xc, REG,0 ' byte "base", hd+xc, REG,base byte "digits", hd+xc, REG,digits byte "delim", hd+xc, REG,delim byte "word", hd+xc, REG,wordbuf byte "unum", hd+xc, REG,unum byte "names", hd+xc, REG,names byte "here", hd+xc, REG,here byte "codes", hd+xc, REG,codes byte "free", hd+xc, REG,free byte "errors", hd+xc, REG,errors byte "HERE", hd+xc, XCALL,xHERE byte "'", hd+xc+im, XCALL,xTICK byte "\", hd+xc+im, XCALL,xCOMMENT byte "(", hd+xc+im, XCALL,xBRACE byte "{", hd+xc+im, XCALL,xCURLY byte $22, hd+xc+im, XCALL,x_STR_ byte $2E,$22, hd+xc+im, XCALL,x_PSTR_ ' Building words byte "FOR", hd+xc+im, XCALL,x_FOR_ byte "NEXT", hd+xc+im, XCALL,x_NEXT_ byte "DO", hd+xc+im, XCALL,x_DO_ byte "ADO", hd+xc+im, XCALL,x_ADO_ byte "LOOP", hd+xc+im, XCALL,x_LOOP_ byte "+LOOP", hd+xc+im, XCALL,x_PLOOP_ byte "IF", hd+xc+im, XCALL,x_IF_ byte "ELSE", hd+xc+im, XCALL,x_ELSE_ byte "THEN", hd+xc+im, XCALL,x_THEN_ byte "ENDIF", hd+xc+im, XCALL,x_THEN_ byte "BEGIN", hd+xc+im, XCALL,x_BEGIN_ byte "UNTIL", hd+xc+im, XCALL,x_UNTIL_ byte "AGAIN", hd+xc+im, XCALL,x_AGAIN_ byte "WHILE", hd+xc+im, XCALL,x_IF_ byte "REPEAT", hd+xc+im, XCALL,x_REPEAT_ byte ":", hd+xc+im, XCALL,xCOLON byte ";", hd+xc+im, XCALL,xENDCOLON byte "CREATE", hd+xc+im, XCALL,xCREATE byte "+XCALL", hd+xc, XCALL,xAddXCALL byte "ITEM", hd+xc, XCALL,xITEM byte "ITEM@", hd+xc, XCALL,xITEMFT byte "ITEMS", hd+xc, XCALL,xITEMS byte "NFA>CFA", hd+xc, XCALL,xNFACFA byte "WORDS", hd+xc, XCALL,xWORDS byte "END", hd+xc, XCALL,xEND enddict byte 0,0 last Extensions/TestingsForth extensions and testingspaste in console at runtime Forth runtime compilerForth runtime compiler test sourceSOURCE CODE... TACHYON : START CNT@ >L ; : LAP CNT@ L> - #80,000 / ; : SCL 28d MASK ; : SDA 29d MASK ; : SDA? 29d IN ; : IICST SDA INPUTS SCL OUTSET SDA OUTCLR SCL OUTCLR ; : IICSP SDA OUTCLR SCL OUTSET SDA INPUTS ; { This routine runs at an I2C speed of 125kHz } : IIC! ( data -- flg ) \ write a byte to the I2C bus and return with the ack (0=ack) #24 REV SCL SWAP SDA DUP OUTSET SWAP 8 FOR OVER OUT 3RD OUTSET 3RD OUTCLR NEXT DROP INPUTS ( float SDA ) DUP OUTSET SDA? SWAP OUTCLR ( ack clock ) ; \ CLKDAT ( sdat scnt -- data ) ( L: miso mosi sck ) { this version needs CLKDAT to slow down about 7 times to work down to 400kHz : IIC! ( data -- flg ) \ write a byte to the I2C bus and return with the ack (0=ack) 0 >L SDA >L SCL >L 24d REV SCL OUTSET SDA OUTSET 8 CLKDAT SDA INPUTS DROP SCL OUTSET SDA? SCL OUTCLR L> DROP L> L> 2DROP ; } : IIC@ ( ack -- data ) SDA INPUTS 0 8 FOR SCL OUTSET 2* SDA? SCL OUTCLR - NEXT SWAP 0= IF SDA OUTCLR THEN SCL DUP OUTSET OUTCLR SDA INPUTS ; : @EE ( addr -- flg ) IICST $A0 IIC! OVER 8 SHR IIC! OR SWAP IIC! OR ; : EERD ( -- flg ) IICST $A1 IIC! ; : ENDRD 1 IIC@ IICSP ; : EDUMP ( addr cnt -- ) IICSP OVER @EE EERD OR IF 2DROP ." BAD RESPONSE FROM EEPROM " ELSE ADO I $0F AND 0= IF CR I .WORD ." : " THEN 0 IIC@ .BYTE BL EMIT LOOP ENDRD DROP THEN ; : EE! ( byte addr -- ) @EE SWAP IIC! OR IICSP ; : EE@ ( addr -- byte ) @EE SWAP EERD DROP ENDRD ; : ESAVE ( ram eeprom cnt -- ) ROT SWAP ADO BEGIN DUP @EE 0= UNTIL 0 I $40 ADO I C@ IIC! OR LOOP IICSP IF $0D EMIT ." FAIL @" I .WORD THEN SPINNER $40 + $40 +LOOP DROP ; : ELOAD ( eeprom ram cnt -- ) ROT BEGIN @EE 0= UNTIL EERD DROP ADO 0 IIC@ I C! LOOP ENDRD DROP ; END VGA FunctionsForth VGA Functions test sourceSOURCE CODE... TACHYON HEX : CLRSCN pixels W@ $6000 ERASE ; : COLORS colors W@ W! colors W@ DUP 2+ #382 CMOVE ; $FF04 COLORS { *** this PLOT function is now coded in PASM as part of the kernel : PLOT ( x y -- ) 6 SHL OVER 3 SHR + SWAP 7 AND MASK SWAP pixels W@ + SET ; } : HLINE ( x y length -- ) ROT SWAP ADO I OVER PLOT LOOP DROP ; : VLINE ( x y length -- ) ADO DUP I PLOT LOOP DROP ; { NOTE: now part of kernel : ITEM 2* 2* @REG ; : ITEMS ( items -- ) 0 DO I ITEM ! LOOP ; } : RECT ( x1 y1 xlen ylen -- ) 4 ITEMS 3 ITEM@ 2 ITEM@ 1 ITEM@ HLINE 3 ITEM@ 1 ITEM@ + 2 ITEM@ 0 ITEM@ VLINE 3 ITEM@ 2 ITEM@ 0 ITEM@ VLINE 3 ITEM@ 2 ITEM@ 0 ITEM@ + 1 ITEM@ HLINE ; : BOXES #200 0 DO I I 50 50 RECT 4 +LOOP $C0 $C0 $30 FOR 2DUP $80 $40 RECT SWAP 4 + SWAP 4 - NEXT 2DROP ; : SLANTS 180 0 DO 100 0 DO I J + I PLOT LOOP 4 +LOOP ; \ : RSLANTS 180 0 DO 100 0 DO I 180 J - + 100 I - PLOT LOOP 4 +LOOP ; : X 8 @REG ; : Y #10 @REG ; : VCR 0 X W! ; : VLF #32 Y W+! ; : HOME VCR 0 Y W! ; HOME : CHAR ( ch -- ) DUP 2/ 7 SHL $8000 + ( ch addr ) 20 0 DO DUP @ 3RD 1 AND IF 2/ THEN 10 0 DO DUP 1 AND IF X W@ I + Y W@ J + PLOT THEN 2/ 2/ LOOP DROP 4 + LOOP 2DROP #16 X W+! X W@ #500 > IF VCR VLF THEN ; : CTRL DUP $0D = IF VCR DROP EXIT THEN DUP $0A = IF VLF DROP EXIT THEN DUP $0C = IF HOME CLRSCN DROP EXIT THEN DUP $01 = IF HOME DROP EXIT THEN DUP $1B = IF DROP R> DROP EXIT THEN CHAR ; : VEMIT DUP 20 < IF CTRL ELSE CHAR THEN ; : .VSTR BEGIN C@++ ?DUP WHILE VEMIT REPEAT DROP ; : CRECT ( x y xlen ylen -- ) 4 ITEMS 3 ITEM@ 1 ITEM@ 2/ - 3 ITEM ! 2 ITEM@ 0 ITEM@ 2/ - 2 ITEM ! 3 ITEM@ 2 ITEM@ 1 ITEM@ HLINE 3 ITEM@ 1 ITEM@ + 2 ITEM@ 0 ITEM@ VLINE 3 ITEM@ 2 ITEM@ 0 ITEM@ VLINE 3 ITEM@ 2 ITEM@ 0 ITEM@ + 1 ITEM@ HLINE ; { Translate this Spin function from the Graphics demo repeat y from 1 to 8 repeat x from 0 to 511 plot(x, x/y) } : LINES 1 8 ADO 0 #512 ADO I I J / PLOT LOOP LOOP ; : SCROLL ( lines -- ) 6 SHL >L pixels W@ $8000 IX - IX CMOVE pixels W@ IX + pixels W@ $6000 L> - CMOVE ; : BLANKOFF colors W@ #352 + $20 ERASE ; : DEMO $FF04 COLORS CLRSCN HOME " TACHYON GRAPHICS DEMO " .VSTR LINES 1000d ms BOXES SLANTS 1000d ms $C000 $1000 ADO I colors W@ #384 CMOVE 100d ms $100 +LOOP 8 0 DO pixels W@ 6000h I MASK FILL 100d ms LOOP #384 0 DO 0 I #512 HLINE 4 +LOOP 1000d ms $FF04 COLORS CLRSCN 100h 0 DO I CHAR LOOP $10000 0 DO I COLORS LOOP $FF04 COLORS BLANKOFF 180 FOR 1 SCROLL NEXT 180 FOR 2 SCROLL NEXT 180 FOR 4 SCROLL NEXT CLRSCN 10d 380d ADO 256d 192d I I CRECT 10d +LOOP 4 FOR $04FF COLORS 300d ms $FF04 COLORS 300d ms NEXT CLRSCN BLANKOFF HOME 100h 0 DO I CHAR LOOP " TACHYON GRAPHICS DEMO " .VSTR ; END Used OBJects SourceHS-SerialRx.spin
SOURCE CODE... PUB start(rxdpin, baudrate) long[@rxpin] := |<rxdpin long[@bitticks] := (clkfreq / baudrate) result := @HSSerialRx+4 ' Use cog image for serial buffer (skip 4 for control) cognew(@HSSerialRx, @HSSerialRx) DAT org HSSerialRx add rxwr, par add rxbuf, par mov Y0,rxbuf sub Y0,#4 mov X0,#0 wrlong X0,Y0 mov stticks,bitticks shr stticks,#1 sub stticks,#8 ' compensate timing receive mov rxdata,#0 mov rxcnt,stticks waitpne rxpin,rxpin ' ' START BIT DETECTED ' 'time sample for middle of start bit add rxcnt,cnt ' uses special start bit timing waitcnt rxcnt,bitticks 'sample middle of start bit test rxpin,ina wz 'sample middle of start bit rxcond2 if_nz jmp #receive ' restart if false start ' ' START bit validated ' Read in data bits ' No point in looping as we have plenty of code to play with ' and inlining can lead to higher receive speeds ' waitcnt rxcnt,bitticks test rxpin,ina wc if_c or rxdata,#01 waitcnt rxcnt,bitticks test rxpin,ina wc if_c or rxdata,#02 waitcnt rxcnt,bitticks test rxpin,ina wc if_c or rxdata,#04 waitcnt rxcnt,bitticks test rxpin,ina wc if_c or rxdata,#08 waitcnt rxcnt,bitticks test rxpin,ina wc if_c or rxdata,#$10 waitcnt rxcnt,bitticks test rxpin,ina wc if_c or rxdata,#$20 waitcnt rxcnt,bitticks test rxpin,ina wc if_c or rxdata,#$40 waitcnt rxcnt,bitticks test rxpin,ina wc if_c or rxdata,#$80 waitcnt rxcnt,bitticks ' check stop bit test rxpin,ina wc if_nc jmp #abreak ' discard if framing error (no stop bits) wrbuf rdbyte Y0,rxwr ' rxwr points to byte index in hub mov X0,rxbuf add X0,Y0 ' X points to buffer location to store wrbyte rxdata,X0 add Y0,#1 wrbyte Y0,rxwr mov breakcnt,#3 'reset any break detection in progress jmp #receive 'byte done, receive next byte abreak djnz breakcnt,#receive mov Y0,#$0FF hubop Y0,#0 jmp $ 'takes a while to reset, meanwhile.. long 0[16] ' make sure this code image is more than 256+4 bytes rxpin long 0 'mask of rx pin rxwr long 3 ' byte address of rxwr in hub rxbuf long 4 ' pointer to rxbuf in hub memory bitticks long 0 stticks long 0 breakcnt long 40 rxcnt res 1 rxdata res 1 'assembled character X0 res 1 Y0 res 1 endcode.spin' the last object which gets compiled last and thus can give us an indication of where we can ' locate free memory (maybe this method can be improved upon but it works for now) SOURCE CODE... PUB start result := @@stop+$20 PUB stop |