.:.:-- TACHYON --:.:.


A very fast and very small Forth byte code interpreter for the Propeller chip.
2012 Peter Jakacki

Introduction

Features: Small memory footprint - approximately 4K including space for buffers and dictionary expansion Low level words are written in PASM and accessed by the Forth run-time interpreter as single byte codes. Byte codes are read from hub RAM and directly address first 256 longs of PASM code in cog Support for LMM operations planned Interpreted byte code definitions (subroutines composed of bytecodes) are referenced either as: 2 bytes - XCALL opcode + byte index into bytecode table 2 bytes - RCALL opcode + relative offset back (-255) 3 bytes - WCALL opcode + 16-bit relative address = 3 bytes All literals and strings are byte aligned Fast I/O bit-bashing support Flexible SPI or I2C PASM code support words in kernel Construct fast serial drivers with minimal code Holds Forth headers in EEPROM or SD storage Kernel's dictionary is searched in reused RAM (from VM's cog image) Searches the dictionary using rapid index key searching by first character No hub RAM is used by headers (except cog image reuse) Even 32K EEPROMs can be used if the area is in RAM is normally rewritten (i.e. video memory) Option to hold additional information per defintion such as stack usage and description Kernel compiled in standard manner via Spin tools so other Spin objects can be combined Three stacks in COG RAM: Data, Return, and Loop Access loop indices outside of definitions allows efficient factoring Avoids manipulation and corruption of return stack Static stack arrays for direct addressing of stack items Intrinsically safe data stack overflow and underflow - optional error reporting Empty loops can execute in 550ns to 875ns (absolute worst case) 350ns minimum instruction cycle time Two to one stack operations ( + * AND etc) inc opcode fetch take 900ns to 1.087us (absolute worse case) * The header file is compiled in this file and loaded in but only needs to use it's location in EEPROM as the image in RAM can be reclaimed for user code or video memory etc. (Headers are in EEPROM automatically when source is compiled in Spin)

Global CONstants

Clock, Ports, Stack sizes


SOURCE 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 Video


SOURCE CODE...
sync            long 0
colors          word 0[192]


Global CONstants for Video


SOURCE 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 Methods


Start

 - 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 Cog

TACHYON PASM KERNEL

SOURCE CODE...
                        org     $10
s                       ' just an offset to be used in DAT sections rather than the distracting +$10

'


ByteCodes

Byte 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 Exit


SOURCE 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 Operators


SOURCE 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


Arithmetic


SOURCE 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


Boolean


SOURCE 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


Comparision


SOURCE 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


Memory


SOURCE 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


Literals


SOURCE 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 Constants


SOURCE 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


Variables


SOURCE 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 Access


SOURCE 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 Access


SOURCE 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 & Loop


SOURCE 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


Stack


SOURCE 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


Emit


SOURCE CODE...
' EMIT ( char -- )
EMIT                    mov     X,tos
                        call    #transmit
                        jmp     #DROP


Registers

Registers can be used just like variables and the interpreted kernel uses some for itself
128 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


Wait


SOURCE 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


String


SOURCE 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


Key

The 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 Routines

Code 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 Interpreter


SOURCE 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


Literals


SOURCE 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


Arithmetic


SOURCE 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 Handler


SOURCE 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 Handler


SOURCE 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 Output


SOURCE 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 Variables


SOURCE 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)


CONstants

define some constants used by this cog
The 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 Area

CONstants


SOURCE CODE...
carry           = 1
zero            = 2

numpadsz                = 16

' flags
echo            = 1
defining                = $80


Allocate Memory

Allocate storage memory for buffers and other variables

SOURCE 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 Routines

debug print routines - also used by DUMP etc

SOURCE 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 Formatting


SOURCE 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


Operators


SOURCE 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


Loops


SOURCE 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


Fills


SOURCE 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 Registers


SOURCE 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 Base

change the default number bases

SOURCE 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 Operations


SOURCE 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 Extensions

Most of these words are acted upon immediately rather than compiled as they are
part 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 Handlers

Replacing 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 Terinal

apply this label to the main startup word

SOURCE 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 EEPROM

Although 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 CONstants


SOURCE 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 DATa

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

SOURCE 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/Testings

Forth extensions and testings
paste in console at runtime

Forth runtime compiler

Forth runtime compiler test source

SOURCE 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 Functions

Forth VGA Functions test source

SOURCE 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 Source

HS-SerialRx.spin


**************************************************** * HIGH-SPEED PRECISION SERIAL RECEIVE * * HS-SerialRx * * 2008,2012 Peter Jakacki * *************************************************** 17/07/12 Modify for use with Tachyon Forth Need to supply the buffer address back from start routine perhaps Use the cog image in hub RAM for the buffer Interface is simple read & write indexes July 21,2012 Added break detect to reboot Prop July 25,2012 Improved start timing - 3M baud start bit sampled at 220ns then 175ns/bit July 30,2012 Added mods from Kuroneko to remove @@@ operator

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