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 OBJects
Tachyon1v0-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 |