1606 lines
67 KiB
Plaintext
Executable File
1606 lines
67 KiB
Plaintext
Executable File
{
|
|
############################################################################
|
|
# PFTH - This program implements a Forth interpreter.
|
|
#
|
|
# Copyright (c) 2012, 2013 Dave Hein
|
|
# MIT Licensed
|
|
############################################################################
|
|
}
|
|
con
|
|
_clkmode = xtal1+pll16x
|
|
_clkfreq = 80_000_000
|
|
|
|
' SD Pin Definitions
|
|
'DO = 10
|
|
'CLK = 11
|
|
'DI = 9
|
|
'CS = 25
|
|
|
|
'Q = 16 ' Object Offset
|
|
|
|
FLAG_IMMEDIATE = 1
|
|
FLAG_CORE = $10 | $80
|
|
FLAG_LIT = $12 | $80
|
|
FLAG_VAR = $20 | $80
|
|
FLAG_DEF = $00 | $80
|
|
FLAG_JMP = $0A | $80
|
|
FLAG_SEMI = FLAG_CORE | FLAG_IMMEDIATE
|
|
{
|
|
obj
|
|
'spi : "mount"
|
|
|
|
'*******************************************************************************
|
|
' This Spin code waits three seconds and then starts the Forth cog
|
|
'*******************************************************************************
|
|
pub main(argc, argv)
|
|
waitcnt(clkfreq+cnt)
|
|
'spi.mount_explicit(@spi_vars, DO, CLK, DI, CS)
|
|
coginit(cogid, @forth, @pfthconfig)
|
|
|
|
dat
|
|
pfthconfig long @xboot_1+Q ' Initial word to execute
|
|
long @stack+Q+16 ' Starting stack pointer
|
|
long @stack+Q+16 ' Empty stack pointer value
|
|
long @retstk+Q ' Starting return pointer
|
|
long @retstk+Q ' Empty return pointer value
|
|
stack long 0[100] ' Data stack
|
|
retstk long 0[100] ' Return stack
|
|
|
|
'*******************************************************************************
|
|
' pfth cog code
|
|
'*******************************************************************************
|
|
org 0
|
|
forth
|
|
parm mov parm, par
|
|
}
|
|
Q = 0 ' Object offset for the top object
|
|
'rx_pin = 91
|
|
'tx_pin = 90
|
|
rx_pin = 31
|
|
tx_pin = 30
|
|
|
|
DAT
|
|
orgh $380
|
|
org 0
|
|
|
|
' Entry point for the Forth interpreter
|
|
forth 'mov pc, a_interp
|
|
'or outc, tx_mask
|
|
'or dirc, tx_mask
|
|
'getcnt temp2
|
|
'add temp2, delay_time
|
|
'waitcnt temp2, #0
|
|
jmp #parm
|
|
parval long @pfthconfig
|
|
'tx_mask long 1 << (64 - TX_PIN) ' must be in dirc
|
|
delay_time long 80000000 * 2
|
|
|
|
parm mov parm, parval
|
|
parm1 rdlong pc, parm
|
|
parm2 add parm, #4
|
|
parm3 rdlong stackptr, parm
|
|
parm4 add parm, #4
|
|
temp rdlong stackptr0, parm
|
|
temp1 add parm, #4
|
|
temp2 rdlong returnptr, parm
|
|
temp3 add parm, #4
|
|
temp4 rdlong returnptr0, parm
|
|
jmp #innerloop ' Begin execution
|
|
|
|
'*******************************************************************************
|
|
' Execute the words contained in the body of a word
|
|
' Changes parm, temp1
|
|
'*******************************************************************************
|
|
execlistfunc add parm, #4 ' Get body from XT
|
|
innerloopcall wrlong pc, returnptr ' Push PC to return stack
|
|
add returnptr, #4
|
|
mov pc, parm ' Set new value for PC
|
|
|
|
'*******************************************************************************
|
|
' Get an execution token from the location pointed to by the program counter
|
|
' Increment the program counter, fetch the code pointer and jump to it
|
|
' Changes parm, temp1, pc
|
|
'*******************************************************************************
|
|
innerloop rdword parm, pc wz
|
|
if_z jmp #exitfunc
|
|
add pc, #2
|
|
rdword temp1, parm
|
|
jmp temp1
|
|
|
|
pc long @xboot_1+Q ' Program Counter
|
|
|
|
'*******************************************************************************
|
|
' Stop executing the current word, and return to the calling word
|
|
' No Changes
|
|
'*******************************************************************************
|
|
exitfunc sub returnptr, #4
|
|
rdlong pc, returnptr
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Abort or quit execution, and return to the interpreter
|
|
' No Changes
|
|
'*******************************************************************************
|
|
abortfunc mov stackptr, stackptr0
|
|
quitfunc mov returnptr, returnptr0
|
|
add returnptr, #4 ' Use second entry return stack
|
|
rdlong pc, returnptr
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Push the value contained in the word's body onto the stack
|
|
' No changes
|
|
'*******************************************************************************
|
|
confunc add parm, #4
|
|
rdlong parm1, parm
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Push the address of the word's body onto the stack
|
|
' Execute the words pointed to by the does pointer, if non-zero
|
|
' No changes
|
|
'*******************************************************************************
|
|
varfunc mov parm1, parm
|
|
add parm1, #4
|
|
call #push1
|
|
|
|
'*******************************************************************************
|
|
' Execute the words pointed to by the does pointer, if non-zero
|
|
' No changes
|
|
'*******************************************************************************
|
|
deferfunc add parm, #2 ' DOES> pointer
|
|
rdword parm, parm wz
|
|
if_z jmp #innerloop ' Done with varfunc
|
|
jmp #innerloopcall ' Execute DOES> code
|
|
|
|
'*******************************************************************************
|
|
' Execute the word on the stack
|
|
' Changes parm, temp1
|
|
'*******************************************************************************
|
|
executefunc sub stackptr, #4
|
|
rdlong parm, stackptr
|
|
rdlong temp1, parm
|
|
jmp temp1 ' Execute code
|
|
|
|
'*******************************************************************************
|
|
' Execute the PASM instruction on the TOS using the next value on the stack as
|
|
' the destination register data. Return the result on the stack.
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
cogx1func call #pop2
|
|
mov cogx1instr, parm2
|
|
'movd cogx1instr, #parm1
|
|
nop
|
|
cogx1instr nop
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Duplicate the top of stack
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
dupfunc call #pop1
|
|
call #push1
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Swap the top two items on the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
swapfunc call #pop2
|
|
wrlong parm2, stackptr
|
|
add stackptr, #4
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Get the next word from the input buffer using the delimiter from the stack
|
|
' Changes parm, parm1, parm2, temp1, temp2
|
|
'*******************************************************************************
|
|
wordfunc sub stackptr, #4
|
|
rdlong parm, stackptr
|
|
call #word_del
|
|
mov temp1, #1
|
|
shl temp1, #15
|
|
sub temp1, parm2
|
|
sub temp1, #1
|
|
wrlong temp1, stackptr
|
|
add stackptr, #4
|
|
wrbyte parm2, temp1
|
|
cmps parm2, #0 wc, wz
|
|
if_c_or_z jmp #innerloop
|
|
:loop add temp1, #1
|
|
rdbyte temp2, parm1
|
|
add parm1, #1
|
|
wrbyte temp2, temp1
|
|
djnz parm2, @:loop
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Find the word specfied on the stack in the dictionary
|
|
' Changes parm1, parm2, temp4
|
|
'*******************************************************************************
|
|
findfunc call #pop1
|
|
mov temp4, parm1
|
|
add parm1, #1
|
|
rdbyte parm2, temp4
|
|
call #findword
|
|
mov parm1, parm wz
|
|
if_z jmp #findfunc1
|
|
call #link2xt
|
|
call #push1
|
|
add parm, #2 ' Point to flag byte
|
|
rdbyte parm1, parm
|
|
and parm1, #1 ' Check immediate bit
|
|
shl parm1, #1
|
|
sub parm1, #1 ' Return 1 if set, -1 if not
|
|
call #push1
|
|
jmp #innerloop
|
|
findfunc1 mov parm1, temp4
|
|
call #push1
|
|
mov parm1, #0
|
|
call #push1
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Send the character from the stack to the output port
|
|
' Changes parm
|
|
'*******************************************************************************
|
|
emitfunc call #pop1
|
|
mov parm, parm1
|
|
call #putch
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Get a character from the input port and put it on the stack
|
|
' Changes parm, parm1
|
|
'*******************************************************************************
|
|
getcharfunc call #getch
|
|
mov parm1, parm
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Get a character from the files stored in memory and put it on the stack
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
getfcharfunc rdbyte parm1, infileptr
|
|
add infileptr, #1
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Get an address and value from the stack, and store the value at the address
|
|
' No changes
|
|
'*******************************************************************************
|
|
storefunc call #pop2
|
|
wrlong parm1, parm2
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Fetch a value from the address specified on the stack, and put it on the stack
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
fetchfunc call #pop1
|
|
rdlong parm1, parm1
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Get an address and word from the stack, and store the word at the address
|
|
' No changes
|
|
'*******************************************************************************
|
|
wstorefunc call #pop2
|
|
wrword parm1, parm2
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Fetch a word from the address specified on the stack, and put it on the stack
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
wfetchfunc call #pop1
|
|
rdword parm1, parm1
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Get an address and byte from the stack, and store the byte at the address
|
|
' No changes
|
|
'*******************************************************************************
|
|
cstorefunc call #pop2
|
|
wrbyte parm1, parm2
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Fetch a byte from the address specified on the stack, and put it on the stack
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
cfetchfunc call #pop1
|
|
rdbyte parm1, parm1
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Add two values from the stack, and write the result back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
plusfunc call #pop2
|
|
add parm1, parm2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Subtract two values from the stack, and write the result back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
minusfunc call #pop2
|
|
sub parm1, parm2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Multiply two values from the stack, and write the result back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
multfunc call #pop2
|
|
call #multiply
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Divide two values from the stack, and write the result back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
dividefunc call #pop2
|
|
call #divide
|
|
mov parm1, parm2
|
|
test parm3, #1 wc
|
|
if_c neg parm1, parm1
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Compute the modulus from two values from the stack, and write the result back
|
|
' to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
modfunc call #pop2
|
|
call #divide
|
|
test parm3, #2 wc
|
|
if_c neg parm1, parm1
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Compare two values from the stack to determine if the second one is less than
|
|
' the first one, and write the result back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
lessfunc call #pop2
|
|
cmps parm1, parm2 wc
|
|
if_c neg parm1, #1
|
|
if_nc mov parm1, #0
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Compare two values from the stack to determine if they are equal, and write
|
|
' the result back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
equalfunc call #pop2
|
|
cmp parm1, parm2 wz
|
|
if_z neg parm1, #1
|
|
if_nz mov parm1, #0
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Compare two values from the stack to determine if the second one is greater
|
|
' than the first one, and write the result back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
greaterfunc call #pop2
|
|
cmps parm1, parm2 wc, wz
|
|
if_nz_and_nc neg parm1, #1
|
|
if_z_or_c mov parm1, #0
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Compute the logical AND of two values from the stack, and write the result
|
|
' back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
andfunc call #pop2
|
|
and parm1, parm2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Compute the logical OR of two values from the stack, and write the result
|
|
' back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
orfunc call #pop2
|
|
or parm1, parm2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Compute the logical XOR of two values from the stack, and write the result
|
|
' back to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
xorfunc call #pop2
|
|
xor parm1, parm2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Right-shift the second value on the stack by the number of bits specified by
|
|
' the first value on the stack, and write the result to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
rshiftfunc call #pop2
|
|
shr parm1, parm2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Left-shift the second value on the stack by the number of bits specified by
|
|
' the first value on the stack, and write the result to the stack
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
lshiftfunc call #pop2
|
|
shl parm1, parm2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Push the stack depth to the stack
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
depthfunc mov parm1, stackptr
|
|
sub parm1, stackptr0
|
|
sar parm1, #2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Drop the top value from the stack
|
|
' No changes
|
|
'*******************************************************************************
|
|
dropfunc sub stackptr, #4
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Use the value on top of the stack as an index to another value in the stack,
|
|
' and write its value to the stack
|
|
' No changes
|
|
'*******************************************************************************
|
|
pickfunc call #pop1
|
|
call #indexstack
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Use the value on top of the stack as and index to remove another value from
|
|
' the stack, and place it at the top of the stack.
|
|
' Changes temp1, temp2, temp3, temp4
|
|
'*******************************************************************************
|
|
rollfunc call #pop1
|
|
cmp parm1, #0 wc, wz
|
|
if_c_or_z jmp #innerloop
|
|
mov temp3, parm1
|
|
call #indexstack
|
|
mov temp2, temp1
|
|
:loop add temp2, #4
|
|
rdlong temp4, temp2
|
|
wrlong temp4, temp1
|
|
add temp1, #4
|
|
djnz temp3, @:loop
|
|
wrlong parm1, temp1
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Pop the value from the top of the stack, and push it onto the return stack.
|
|
' No changes
|
|
'*******************************************************************************
|
|
torfunc call #pop1
|
|
wrlong parm1, returnptr
|
|
add returnptr, #4
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Pop the value from the top of the return stack and push it to the stack.
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
fromrfunc sub returnptr, #4
|
|
rdlong parm1, returnptr
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Push the value on the stack pointed to by the PC and increment the PC
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
_litfunc rdword parm1, pc
|
|
add pc, #2
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Convert the string described by the address and length on the top of the
|
|
' stack to a hex number, and push it to the stack
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
_gethexfunc call #pop2
|
|
call #gethex
|
|
mov parm1, parm
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Create a variable, and add it to the dictionary
|
|
' Changes parm3
|
|
'*******************************************************************************
|
|
createfunc mov parm3, #varfunc
|
|
mov parm4, #FLAG_VAR
|
|
call #create
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Create an executable word, and add it to the dictionary. Set the compile
|
|
' state to -1
|
|
' Changes parm3, temp1
|
|
'*******************************************************************************
|
|
colonfunc mov parm3, #execlistfunc
|
|
mov parm4, #FLAG_DEF
|
|
call #create
|
|
if_z jmp #innerloop
|
|
neg temp1, #1
|
|
wrlong temp1, a_state
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Compile a zero into memory indicating the end of an executable word, and set
|
|
' the compile flag to zero
|
|
' Changes temp1, temp2
|
|
'*******************************************************************************
|
|
semicolonfunc mov temp1, #0
|
|
wrlong temp1, a_state
|
|
rdlong temp2, a_dp
|
|
wrword temp1, temp2
|
|
add temp2, #2
|
|
wrlong temp2, a_dp
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Fetch a value from the specified cog address, and put it on the stack
|
|
' the compile flag to zero
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
cogfetchfunc call #pop1
|
|
'movs cogfetch1, parm1
|
|
nop
|
|
cogfetch1 mov parm1, 0-0
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' Get a cog address and value from the stack, and store the value at the address
|
|
' the compile flag to zero
|
|
' Changes parm1, parm2
|
|
'*******************************************************************************
|
|
cogstorefunc call #pop2
|
|
'movd cogstore1, parm2
|
|
nop
|
|
cogstore1 'mov 0-0, parm1
|
|
jmp #innerloop
|
|
|
|
|
|
'*******************************************************************************
|
|
' Print out an 8-digit hex number to the output port.
|
|
' Changes parm
|
|
'*******************************************************************************
|
|
dotxfunc mov parm, #"$"
|
|
call #putch
|
|
call #pop1
|
|
call #printhex
|
|
mov parm, #" "
|
|
call #putch
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' If top of stack is zero, jump to address contained in location at current PC.
|
|
' Otherwise, increment the PC
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
_jzfunc call #pop1
|
|
if_z rdword pc, pc
|
|
if_nz add pc, #2
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Copy bytes from the source to the destination
|
|
' Changes parm1
|
|
'*******************************************************************************
|
|
cmovefunc sub stackptr, #4
|
|
rdlong parm3, stackptr
|
|
call #pop2
|
|
cmps parm3, #0 wz, wc
|
|
if_c_or_z jmp #innerloop
|
|
:loop rdbyte temp1, parm1
|
|
add parm1, #1
|
|
wrbyte temp1, parm2
|
|
add parm2, #1
|
|
djnz parm3, @:loop
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Perform the increment and compare for the loop word
|
|
' Changes parm1, parm2, parm3
|
|
'*******************************************************************************
|
|
_loopfunc call #pop1 ' Get increment
|
|
sub returnptr, #8
|
|
rdlong parm3, returnptr ' Get upper limit
|
|
add returnptr, #4
|
|
rdlong parm2, returnptr ' Get index
|
|
add parm1, parm2 ' index + increment
|
|
wrlong parm1, returnptr ' Push index back
|
|
add returnptr, #4
|
|
cmps parm1, parm3 wc
|
|
if_nc neg parm1, #1
|
|
if_c mov parm1, #0
|
|
jmp #push_jmp
|
|
|
|
'*******************************************************************************
|
|
' The following code implements the basic functions used by the kernel words
|
|
'*******************************************************************************
|
|
|
|
'*******************************************************************************
|
|
' Create a word entry in the dictionary
|
|
' Changes parm, parm1, parm2, temp1, temp2
|
|
'*******************************************************************************
|
|
create mov parm, #" "
|
|
call #word_del
|
|
if_z jmp #create_ret
|
|
rdlong temp1, a_dp ' Align DP
|
|
add temp1, #3
|
|
and temp1, minus4
|
|
rdlong temp2, a_last
|
|
wrword temp2, temp1 ' Write the link pointer
|
|
wrlong temp1, a_last ' Update LAST
|
|
add temp1, #2
|
|
|
|
wrbyte parm4, temp1 ' Write the flag
|
|
add temp1, #1
|
|
wrbyte parm2, temp1 ' Write the length
|
|
add temp1, #1
|
|
cmps parm2, #0 wc, wz
|
|
if_c_or_z jmp #create_done
|
|
:loop rdbyte temp2, parm1 ' Copy the name
|
|
add parm1, #1
|
|
wrbyte temp2, temp1
|
|
add temp1, #1 wz
|
|
djnz parm2, @:loop
|
|
|
|
create_done mov temp2, #0 ' Pad with 0's to align
|
|
:loop1 test temp1, #3 wz
|
|
if_z jmp #create_aligned
|
|
wrbyte temp2, temp1
|
|
add temp1, #1
|
|
jmp #:loop1
|
|
|
|
create_aligned wrword parm3, temp1 ' Write the code pointer
|
|
add temp1, #2
|
|
wrword temp2, temp1 ' Write the DOES> pointer
|
|
add temp1, #2 wz ' Clear zero flag
|
|
|
|
wrlong temp1, a_dp
|
|
create_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Get one character from the input port.
|
|
' Input none
|
|
' Changes parm, temp, temp1, temp2
|
|
' Output parm
|
|
'*******************************************************************************
|
|
{
|
|
getch mov parm, ina
|
|
and parm, inbit wz
|
|
if_nz jmp #getch
|
|
mov temp2, cnt
|
|
mov temp, bitcycles
|
|
shr temp, #1
|
|
add temp2, temp
|
|
mov temp1, #10
|
|
:loop waitcnt temp2, bitcycles
|
|
mov temp, ina
|
|
and temp, inbit
|
|
ror parm, #1
|
|
or parm, temp
|
|
djnz temp1, #:loop
|
|
ror parm, #31 - 8
|
|
and parm, #255
|
|
getch_ret ret
|
|
|
|
inbit long $80000000
|
|
}
|
|
getch getp #RX_PIN wz
|
|
if_nz jmp #getch
|
|
getcnt temp2
|
|
mov temp3, bitcycles
|
|
shr temp3, #1
|
|
add temp2, temp3
|
|
mov temp1, #10
|
|
mov parm, #0
|
|
:loop waitcnt temp2, bitcycles
|
|
ror parm, #1
|
|
getp #RX_PIN wc
|
|
if_c or parm, #1
|
|
djnz temp1, @:loop
|
|
rol parm, #8
|
|
and parm, #255
|
|
ret
|
|
bitcycles long 80_000_000 / 115_200
|
|
|
|
'*******************************************************************************
|
|
' Send one character to the output port.
|
|
' Input parm
|
|
' Changes parm, temp1, temp2
|
|
' Output none
|
|
'*******************************************************************************
|
|
{
|
|
putch rdlong temp1, a_verbose wz
|
|
if_z jmp putch_ret
|
|
or parm, #$100
|
|
shl parm, #1
|
|
mov temp1, #10
|
|
mov temp2, bitcycles
|
|
add temp2, cnt
|
|
:loop shr parm, #1 wc
|
|
if_c or outa, outbit
|
|
if_nc andn outa, outbit
|
|
waitcnt temp2, bitcycles
|
|
djnz temp1, #:loop
|
|
putch_ret ret
|
|
|
|
outbit long $40000000
|
|
}
|
|
putch rdlong temp1, a_verbose wz
|
|
if_z ret
|
|
or parm, stopbits
|
|
shl parm, #1
|
|
mov temp1, #11
|
|
getcnt temp2
|
|
add temp2, bitcycles
|
|
:loop ror parm, #1 wc
|
|
setpc #TX_PIN
|
|
waitcnt temp2, bitcycles
|
|
djnz temp1, @:loop
|
|
ret
|
|
stopbits long $300
|
|
|
|
'*******************************************************************************
|
|
' Skip the specified character in the input buffer
|
|
' Input parm
|
|
' Changes temp, temp1
|
|
' Output none
|
|
'*******************************************************************************
|
|
skipchar cmps temp1, temp2 wc
|
|
if_nc jmp #skipchar_ret
|
|
rdlong temp, a_tib
|
|
add temp, temp1
|
|
rdbyte temp, temp
|
|
cmp temp, parm wz
|
|
if_nz jmp #skipchar_ret
|
|
add temp1, #1
|
|
jmp #skipchar
|
|
skipchar_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Find the next occurance of the specified character in the input buffer
|
|
' Input parm
|
|
' Changes temp, temp1
|
|
' Output none
|
|
'*******************************************************************************
|
|
findchar cmps temp1, temp2 wc
|
|
if_nc jmp #findchar_ret
|
|
rdlong temp, a_tib
|
|
add temp, temp1
|
|
rdbyte temp, temp
|
|
cmp temp, parm wz
|
|
if_z jmp #findchar_ret
|
|
add temp1, #1
|
|
jmp #findchar
|
|
findchar_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Find the next word in the input buffer delimited by the specified character
|
|
' Input parm
|
|
' Changes parm1, parm2, temp1, temp2
|
|
' Output none
|
|
'*******************************************************************************
|
|
word_del
|
|
rdlong temp1, a_inputidx
|
|
rdlong temp2, a_inputlen
|
|
call #skipchar
|
|
mov parm1, temp1
|
|
call #findchar
|
|
mov parm2, temp1
|
|
sub parm2, parm1 wz
|
|
rdlong temp, a_tib
|
|
add parm1, temp
|
|
cmps temp1, temp2 wc
|
|
if_c add temp1, #1
|
|
wrlong temp1, a_inputidx
|
|
word_del_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Find the specified word in the dictionary
|
|
' Input parm1, parm2
|
|
' Changes parm, parm3, parm4
|
|
' Output parm
|
|
'*******************************************************************************
|
|
findword rdlong parm, a_last wz
|
|
if_z jmp #findword_ret
|
|
:loop mov parm3, parm
|
|
add parm3, #3
|
|
rdbyte parm4, parm3
|
|
add parm3, #1
|
|
call #compare
|
|
if_z jmp #findword_ret
|
|
rdword parm, parm wz
|
|
if_nz jmp #:loop
|
|
findword_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Do a case insensitive comparison of two character strings
|
|
' Input parm1, parm2, parm3, parm4
|
|
' Changes parm3, parm4, temp, temp1, temp2
|
|
' Outut Z
|
|
'*******************************************************************************
|
|
compare cmps parm2, #1 wc, wz
|
|
if_c jmp #compare_ret
|
|
cmp parm2, parm4 wz
|
|
if_nz jmp #compare_ret
|
|
mov temp, parm1
|
|
:loop rdbyte temp1, temp
|
|
call #toupper
|
|
mov temp2, temp1
|
|
rdbyte temp1, parm3
|
|
call #toupper
|
|
cmp temp1, temp2 wz
|
|
if_nz jmp #compare_ret
|
|
add temp, #1
|
|
add parm3, #1
|
|
djnz parm4, @:loop
|
|
compare_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Convert a character to uppercase
|
|
' Input temp1
|
|
' Changes temp1
|
|
' Ouput temp1
|
|
'*******************************************************************************
|
|
toupper cmp temp1, #"a" wc
|
|
if_c jmp #toupper_ret
|
|
cmp temp1, #"z" wc, wz
|
|
if_nc_and_nz jmp #toupper_ret
|
|
sub temp1, #"a" - "A"
|
|
toupper_ret ret
|
|
|
|
|
|
'*******************************************************************************
|
|
' Print an 8-digit hex value to the output port
|
|
' Input parm1
|
|
' Changes parm, parm1, parm2
|
|
' Output none
|
|
'*******************************************************************************
|
|
printhex mov parm2, #8
|
|
:loop rol parm1, #4
|
|
mov parm, #15
|
|
and parm, parm1
|
|
add parm, a_hexstr
|
|
rdbyte parm, parm
|
|
call #putch
|
|
djnz parm2, @:loop
|
|
printhex_ret ret
|
|
|
|
|
|
'*******************************************************************************
|
|
' Convert a string to a hex number
|
|
' Input parm1, parm2
|
|
' Changes parm, temp, temp1, temp2
|
|
' Output parm
|
|
'*******************************************************************************
|
|
gethex mov parm, #0
|
|
cmps parm2, #0 wc, wz
|
|
if_c_or_z jmp #gethex_ret
|
|
mov temp1, parm1
|
|
mov temp2, parm2
|
|
:loop rdbyte temp, temp1
|
|
add temp1, #1
|
|
sub temp, #"0"
|
|
cmps temp, #10 wc
|
|
if_nc sub temp, #"a"-"0"-10
|
|
shl parm, #4
|
|
add parm, temp
|
|
djnz temp2, @:loop
|
|
gethex_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Push a value onto the data stack
|
|
' Input parm1
|
|
' No changes
|
|
' Output none
|
|
'*******************************************************************************
|
|
push1 wrlong parm1, stackptr
|
|
add stackptr, #4
|
|
push_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Push a value onto the data stack and jump to the innerloop
|
|
' Input parm1
|
|
' No changes
|
|
' Output none
|
|
'*******************************************************************************
|
|
push_jmp wrlong parm1, stackptr
|
|
add stackptr, #4
|
|
jmp #innerloop
|
|
|
|
'*******************************************************************************
|
|
' Pop two values off of the data stack
|
|
' Input none
|
|
' Changes parm1, parm2
|
|
' Output parm1, parm2
|
|
'*******************************************************************************
|
|
pop2 sub stackptr, #4
|
|
rdlong parm2, stackptr
|
|
|
|
'*******************************************************************************
|
|
' Pop one value off of the data stack
|
|
' Input none
|
|
' Changes parm1
|
|
' Ouput parm1
|
|
'*******************************************************************************
|
|
pop1 sub stackptr, #4
|
|
rdlong parm1, stackptr wz
|
|
pop_ret
|
|
pop2_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Read a value on the stack based on an index number
|
|
' Changes parm1, temp1
|
|
'*******************************************************************************
|
|
indexstack neg temp1, parm1
|
|
shl temp1, #2
|
|
sub temp1, #4
|
|
add temp1, stackptr
|
|
rdlong parm1, temp1
|
|
indexstack_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Compute the XT from the address of the link
|
|
' Input: parm1
|
|
' Output: parm1
|
|
' Changes: temp1
|
|
'*******************************************************************************
|
|
link2xt mov temp1, parm1
|
|
add temp1, #3
|
|
rdbyte parm1, temp1 ' Get name length
|
|
add parm1, temp1
|
|
add parm1, #4
|
|
and parm1, minus4 ' Align
|
|
link2xt_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Multiply two 32-bit numbers
|
|
' Changes parm2, temp1, temp2
|
|
'*******************************************************************************
|
|
multiply mov temp1, #0
|
|
mov temp2, #32
|
|
shr parm1, #1 wc
|
|
mmul if_c add temp1, parm2 wc
|
|
rcr temp1, #1 wc
|
|
rcr parm1, #1 wc
|
|
djnz temp2, @mmul
|
|
multiply_ret ret
|
|
|
|
'*******************************************************************************
|
|
' Divide two 32-bit numbers producing a quotient and a remainder
|
|
' Changes parm1, parm2, parm3, temp1, temp2
|
|
'*******************************************************************************
|
|
divide mov temp2, #32
|
|
mov temp1, #0
|
|
abs parm1, parm1 wc
|
|
muxc parm3, #%11
|
|
abs parm2, parm2 wc,wz
|
|
if_c xor parm3, #%01
|
|
' if_nz jmp #mdiv
|
|
' mov parm1, #0
|
|
' jmp divide_ret
|
|
mdiv shr parm2, #1 wc,wz
|
|
rcr temp1, #1
|
|
if_nz djnz temp2, @mdiv
|
|
mdiv2 cmpsub parm1, temp1 wc
|
|
rcl parm2, #1
|
|
shr temp1, #1
|
|
djnz temp2, @mdiv2
|
|
divide_ret ret
|
|
|
|
'*******************************************************************************
|
|
' These are working registers. The parm registers are generally used to pass
|
|
' parameters from one routine to another, and the temp registers are used as
|
|
' temporary storage within a routine.
|
|
'*******************************************************************************
|
|
|
|
'*******************************************************************************
|
|
' Addresses of variables in the dictionary, and the hex table
|
|
'*******************************************************************************
|
|
a_hexstr long @hexstr+Q
|
|
a_last long @last+Q
|
|
a_state long @state+Q
|
|
a_dp long @dp+Q
|
|
a_tib long @tib+Q
|
|
a_verbose long @verbose+Q
|
|
a_inputidx long @greaterin+Q
|
|
a_inputlen long @poundtib+Q
|
|
|
|
'*******************************************************************************
|
|
' The data and return stack pointers, and their base addresses
|
|
'*******************************************************************************
|
|
'stackptr long 0
|
|
'stackptr0 long 0
|
|
'returnptr long 0
|
|
'returnptr0 long 0
|
|
stackptr long @stack+16
|
|
stackptr0 long @stack+16
|
|
returnptr long @retstk
|
|
returnptr0 long @retstk
|
|
|
|
'*******************************************************************************
|
|
' The input file pointer used during initialization
|
|
'*******************************************************************************
|
|
infileptr long @infile+Q
|
|
|
|
'*******************************************************************************
|
|
' Constants
|
|
'*******************************************************************************
|
|
minus4 long -4
|
|
|
|
fit $1f0
|
|
|
|
orgh
|
|
|
|
pfthconfig long @xboot_1+Q ' Initial word to execute
|
|
long @stack+Q+16 ' Starting stack pointer
|
|
long @stack+Q+16 ' Empty stack pointer value
|
|
long @retstk+Q ' Starting return pointer
|
|
long @retstk+Q ' Empty return pointer value
|
|
stack long 0[100] ' Data stack
|
|
retstk long 0[100] ' Return stack
|
|
|
|
'*******************************************************************************
|
|
' Input buffer and hex table
|
|
'*******************************************************************************
|
|
hexstr byte "0123456789abcdef"
|
|
inputbuf byte 0[200]
|
|
|
|
'*******************************************************************************
|
|
' This is the beginning of the dictionary. The kernel words are specified below
|
|
'*******************************************************************************
|
|
exit_L word 0
|
|
byte FLAG_CORE, 4, "exit"
|
|
long
|
|
exit_X word exitfunc, 0
|
|
|
|
quit_L word @exit_L+Q
|
|
byte FLAG_CORE, 4, "quit"
|
|
long
|
|
quit_X word quitfunc, 0
|
|
|
|
abort_L word @quit_L+Q
|
|
byte FLAG_CORE, 5, "abort"
|
|
long
|
|
abort_X word abortfunc, 0
|
|
|
|
execute_L word @abort_L+Q
|
|
byte FLAG_CORE, 7, "execute"
|
|
long
|
|
execute_X word executefunc, 0
|
|
|
|
word_L word @execute_L+Q
|
|
byte FLAG_CORE, 4, "word"
|
|
long
|
|
word_X word wordfunc, 0
|
|
|
|
find_L word @word_L+Q
|
|
byte FLAG_CORE, 4, "find"
|
|
long
|
|
find_X word findfunc, 0
|
|
|
|
getchar_L word @find_L+Q
|
|
byte FLAG_CORE, 7, "getchar"
|
|
long
|
|
getchar_X word getcharfunc, 0
|
|
|
|
getfchar_L word @getchar_L+Q
|
|
byte FLAG_CORE, 8, "getfchar"
|
|
long
|
|
getfchar_X word getfcharfunc, 0
|
|
|
|
key_L word @getfchar_L+Q
|
|
byte FLAG_CORE, 3, "key"
|
|
long
|
|
key_X word deferfunc, @key_B+Q
|
|
key_B word @getfchar_X+Q, 0
|
|
'key_B word @getchar_X+Q, 0
|
|
|
|
create_L word @key_L+Q
|
|
byte FLAG_CORE, 6, "create"
|
|
long
|
|
create_X word createfunc, 0
|
|
|
|
_lit_L word @create_L+Q
|
|
byte FLAG_LIT, 4, "_lit"
|
|
long
|
|
_lit_X word _litfunc, 0
|
|
|
|
_gethex_L word @_lit_L+Q
|
|
byte FLAG_CORE, 7, "_gethex"
|
|
long
|
|
_gethex_X word _gethexfunc, 0
|
|
|
|
emit_L word @_gethex_L+Q
|
|
byte FLAG_CORE, 4, "emit"
|
|
long
|
|
emit_X word emitfunc, 0
|
|
|
|
store_L word @emit_L+Q
|
|
byte FLAG_CORE, 1, "!"
|
|
long
|
|
store_X word storefunc, 0
|
|
|
|
fetch_L word @store_L+Q
|
|
byte FLAG_CORE, 1, "@"
|
|
long
|
|
fetch_X word fetchfunc, 0
|
|
|
|
wstore_L word @fetch_L+Q
|
|
byte FLAG_CORE, 2, "w!"
|
|
long
|
|
wstore_X word wstorefunc, 0
|
|
|
|
wfetch_L word @wstore_L+Q
|
|
byte FLAG_CORE, 2, "w@"
|
|
long
|
|
wfetch_X word wfetchfunc, 0
|
|
|
|
cstore_L word @wfetch_L+Q
|
|
byte FLAG_CORE, 2, "c!"
|
|
long
|
|
cstore_X word cstorefunc, 0
|
|
|
|
cfetch_L word @cstore_L+Q
|
|
byte FLAG_CORE, 2, "c@"
|
|
long
|
|
cfetch_X word cfetchfunc, 0
|
|
|
|
plus_L word @cfetch_L+Q
|
|
byte FLAG_CORE, 1, "+"
|
|
long
|
|
plus_X word plusfunc, 0
|
|
|
|
minus_L word @plus_L+Q
|
|
byte FLAG_CORE, 1, "-"
|
|
long
|
|
minus_X word minusfunc, 0
|
|
|
|
multiply_L word @minus_L+Q
|
|
byte FLAG_CORE, 1, "*"
|
|
long
|
|
multiply_X word multfunc, 0
|
|
|
|
divide_L word @multiply_L+Q
|
|
byte FLAG_CORE, 1, "/"
|
|
long
|
|
divide_X word dividefunc, 0
|
|
|
|
mod_L word @divide_L+Q
|
|
byte FLAG_CORE, 3, "mod"
|
|
long
|
|
mod_X word modfunc, 0
|
|
|
|
and_L word @mod_L+Q
|
|
byte FLAG_CORE, 3, "and"
|
|
long
|
|
and_X word andfunc, 0
|
|
|
|
or_L word @and_L+Q
|
|
byte FLAG_CORE, 2, "or"
|
|
long
|
|
or_X word orfunc, 0
|
|
|
|
xor_L word @or_L+Q
|
|
byte FLAG_CORE, 3, "xor"
|
|
long
|
|
xor_X word xorfunc, 0
|
|
|
|
less_L word @xor_L+Q
|
|
byte FLAG_CORE, 1, "<"
|
|
long
|
|
less_X word lessfunc, 0
|
|
|
|
equal_L word @less_L+Q
|
|
byte FLAG_CORE, 1, "="
|
|
long
|
|
equal_X word equalfunc, 0
|
|
|
|
greater_L word @equal_L+Q
|
|
byte FLAG_CORE, 1, ">"
|
|
long
|
|
greater_X word greaterfunc, 0
|
|
|
|
rshift_L word @greater_L+Q
|
|
byte FLAG_CORE, 6, "rshift"
|
|
long
|
|
rshift_X word rshiftfunc, 0
|
|
|
|
lshift_L word @rshift_L+Q
|
|
byte FLAG_CORE, 6, "lshift"
|
|
long
|
|
lshift_X word lshiftfunc, 0
|
|
|
|
depth_L word @lshift_L+Q
|
|
byte FLAG_CORE, 5, "depth"
|
|
long
|
|
depth_X word depthfunc, 0
|
|
|
|
tib_L word @depth_L+Q
|
|
byte FLAG_VAR, 3, "tib"
|
|
long
|
|
tib_X word varfunc, @tib+Q+4
|
|
tib long @inputbuf+Q
|
|
word @fetch_X+Q, 0
|
|
long
|
|
|
|
poundtib_L word @tib_L+Q
|
|
byte FLAG_VAR, 4, "#tib"
|
|
long
|
|
poundtib_X word varfunc, 0
|
|
poundtib long 0
|
|
|
|
greaterin_L word @poundtib_L+Q
|
|
byte FLAG_VAR, 3, ">in"
|
|
long
|
|
greaterin_X word varfunc, 0
|
|
greaterin long 0
|
|
|
|
dp_L word @greaterin_L+Q
|
|
byte FLAG_VAR, 2, "dp"
|
|
long
|
|
dp_X word varfunc, 0
|
|
dp long @_here+Q
|
|
|
|
last_L word @dp_L+Q
|
|
byte FLAG_VAR, 4, "last"
|
|
long
|
|
last_X word varfunc, 0
|
|
last long @_last+Q
|
|
|
|
state_L word @last_L+Q
|
|
byte FLAG_VAR, 5, "state"
|
|
long
|
|
state_X word varfunc, 0
|
|
state long 0
|
|
|
|
base_L word @state_L+Q
|
|
byte FLAG_VAR, 4, "base"
|
|
long
|
|
base_X word varfunc, 0
|
|
base long 16
|
|
|
|
verbose_L word @base_L+Q
|
|
byte FLAG_VAR, 7, "verbose"
|
|
long
|
|
verbose_X word varfunc, 0
|
|
verbose long 0
|
|
|
|
forth_L word @verbose_L+Q
|
|
byte FLAG_VAR, 5, "forth"
|
|
long
|
|
forth_X word varfunc, 0
|
|
long @forth+Q
|
|
|
|
drop_L word @forth_L+Q
|
|
byte FLAG_CORE, 4, "drop"
|
|
long
|
|
drop_X word dropfunc, 0
|
|
|
|
dup_L word @drop_L+Q
|
|
byte FLAG_CORE, 3, "dup"
|
|
long
|
|
dup_X word dupfunc, 0
|
|
|
|
swap_L word @dup_L+Q
|
|
byte FLAG_CORE, 4, "swap"
|
|
long
|
|
swap_X word swapfunc, 0
|
|
|
|
pick_L word @swap_L+Q
|
|
byte FLAG_CORE, 4, "pick"
|
|
long
|
|
pick_X word pickfunc, 0
|
|
|
|
roll_L word @pick_L+Q
|
|
byte FLAG_CORE, 4, "roll"
|
|
long
|
|
roll_X word rollfunc, 0
|
|
|
|
tor_L word @roll_L+Q
|
|
byte FLAG_CORE, 2, ">r"
|
|
long
|
|
tor_X word torfunc, 0
|
|
|
|
fromr_L word @tor_L+Q
|
|
byte FLAG_CORE, 2, "r>"
|
|
long
|
|
fromr_X word fromrfunc, 0
|
|
|
|
colon_L word @fromr_L+Q
|
|
byte FLAG_CORE, 1, ":"
|
|
long
|
|
colon_X word colonfunc, 0
|
|
|
|
semicolon_L word @colon_L+Q
|
|
byte FLAG_SEMI, 1, ";"
|
|
long
|
|
semicolon_X word semicolonfunc, 0
|
|
|
|
cogfetch_L word @semicolon_L+Q
|
|
byte FLAG_CORE, 4, "cog@"
|
|
long
|
|
cogfetch_X word cogfetchfunc, 0
|
|
|
|
cogstore_L word @cogfetch_L+Q
|
|
byte FLAG_CORE, 4, "cog!"
|
|
long
|
|
cogstore_X word cogstorefunc, 0
|
|
|
|
cogx1_L word @cogstore_L+Q
|
|
byte FLAG_CORE, 5, "cogx1"
|
|
long
|
|
cogx1_X word cogx1func, 0
|
|
|
|
_jz_L word @cogx1_L+Q
|
|
byte FLAG_JMP, 3, "_jz"
|
|
long
|
|
_jz_X word _jzfunc, 0
|
|
|
|
cmove_L word @_jz_L+Q
|
|
byte FLAG_CORE, 5, "cmove"
|
|
long
|
|
cmove_X word cmovefunc, 0
|
|
|
|
dotx_L word @cmove_L+Q
|
|
byte FLAG_CORE, 2, ".x"
|
|
long
|
|
dotx_X word dotxfunc, 0
|
|
|
|
'*******************************************************************************
|
|
' SPI/SD Variables
|
|
'*******************************************************************************
|
|
spi_vars_L word @dotx_L+Q
|
|
byte FLAG_VAR, 8, "spi_vars"
|
|
long
|
|
spi_vars_X word varfunc, 0
|
|
spi_vars long 0 ' SPI_engine_cog
|
|
long 0 ' SPI_command
|
|
long 0 ' SPI_block_index
|
|
long 0 ' SPI_buffer_address
|
|
long 0 ' SD_rootdir
|
|
long 0 ' SD_filesystem
|
|
long 0 ' SD_clustershift
|
|
long 0 ' SD_dataregion
|
|
long 0 ' SD_fat1
|
|
long 0 ' SD_sectorsperfat
|
|
long 0 ' SD_currdir
|
|
|
|
argc_L word @spi_vars_L+Q
|
|
byte FLAG_VAR, 4, "argc"
|
|
long
|
|
argc_X word confunc, 0
|
|
argc_B long 0
|
|
|
|
argv_L word @argc_L+Q
|
|
byte FLAG_VAR, 4, "argv"
|
|
long
|
|
argv_X word confunc, 0
|
|
argv_B long 0
|
|
|
|
hostcwd_L word @argv_L+Q
|
|
byte FLAG_VAR, 7, "hostcwd"
|
|
long
|
|
hostcwd_X word confunc, 0
|
|
hostcwd_B long 0
|
|
|
|
'*******************************************************************************
|
|
' A small number of compiled words follow below. These are used by the boot
|
|
' interpreter.
|
|
'*******************************************************************************
|
|
' : here dp @ ;
|
|
here_L word @hostcwd_L+Q
|
|
byte FLAG_DEF, 4, "here"
|
|
long
|
|
here_X word execlistfunc, 0
|
|
word @dp_X+Q, @fetch_X+Q, 0
|
|
long
|
|
|
|
' : allot dp @ + dp ! ;
|
|
allot_L word @here_L+Q
|
|
byte FLAG_DEF, 5, "allot"
|
|
long
|
|
allot_X word execlistfunc, 0
|
|
word @dp_X+Q, @fetch_X+Q, @plus_X+Q, @dp_X+Q, @store_X+Q, 0
|
|
long
|
|
|
|
' : , here ! 4 allot ;
|
|
comma_L word @allot_L+Q
|
|
byte FLAG_DEF, 1, ","
|
|
long
|
|
comma_X word execlistfunc, 0
|
|
word @here_X+Q, @store_X+Q, @_lit_X+Q, 4, @allot_X+Q, 0
|
|
long
|
|
|
|
' : _jmp r> @ >r ;
|
|
_jmp_L word @comma_L+Q
|
|
byte FLAG_JMP, 4, "_jmp"
|
|
long
|
|
_jmp_X word execlistfunc, 0
|
|
word @fromr_X+Q, @wfetch_X+Q, @tor_X+Q, 0
|
|
long
|
|
|
|
' : count 0 pick 1 + 1 roll c@ ;
|
|
count_L word @_jmp_L+Q
|
|
byte FLAG_DEF, 5, "count"
|
|
long
|
|
count_X word execlistfunc, 0
|
|
word @_lit_X+Q, 0, @pick_X+Q, @_lit_X+Q, 1, @plus_X+Q, @_lit_X+Q, 1, @roll_X+Q, @cfetch_X+Q, 0
|
|
long
|
|
|
|
' : accept ( addr size -- num ) \ Accept a string from the input source
|
|
accept_L word @count_L+Q
|
|
byte FLAG_DEF, 6, "accept"
|
|
long
|
|
accept_X word execlistfunc, 0
|
|
' >r dup
|
|
word @tor_X+Q, @dup_X+Q
|
|
' r> dup 1 < _jz _accept4
|
|
accept_1 word @fromr_X+Q, @dup_X+Q, @_lit_X+Q, 1, @less_X+Q, @_jz_X+Q, @accept_4+Q
|
|
' drop swap - exit
|
|
word @drop_X+Q, @swap_X+Q, @minus_X+Q, @exit_X+Q
|
|
' >r key
|
|
accept_4 word @tor_X+Q, @key_X+Q
|
|
' dup 0d = over 0a = or
|
|
word @dup_X+Q, @_lit_X+Q, $0d, @equal_X+Q, @_lit_X+Q, 1, @pick_X+Q, @_lit_X+Q, $0a, @equal_X+Q, @or_X+Q
|
|
' _jz _accept2
|
|
word @_jz_X+Q, @accept_2+Q
|
|
' cr drop swap -
|
|
word @_lit_X+Q, 13, @emit_X+Q, @_lit_X+Q, 10, @emit_X+Q, @drop_X+Q, @swap_X+Q, @minus_X+Q
|
|
' r> drop exit
|
|
word @fromr_X+Q, @drop_X+Q, @exit_X+Q
|
|
' dup 8 = _jz _accept3
|
|
accept_2 word @dup_X+Q, @_lit_X+Q, 8, @equal_X+Q, @_jz_X+Q, @accept_3+Q
|
|
' drop over over - _jz _accept1
|
|
word @drop_X+Q, @_lit_X+Q, 1, @pick_X+Q, @_lit_X+Q, 1, @pick_X+Q, @minus_X+Q, @_jz_X+Q, @accept_1+Q
|
|
' 1 - r> 1 + >r
|
|
word @_lit_X+Q, 1, @minus_X+Q, @fromr_X+Q, @_lit_X+Q, 1, @plus_X+Q, @tor_X+Q
|
|
' 8 emit bl emit 8 emit _jmp _accept1
|
|
word @_lit_X+Q, 8, @emit_X+Q, @_lit_X+Q, 32, @emit_X+Q, @_lit_X+Q, 8, @emit_X+Q, @_jmp_X+Q, @accept_1+Q
|
|
' dup emit over c! 1 +
|
|
accept_3 word @dup_X+Q, @emit_X+Q, @_lit_X+Q, 1, @pick_X+Q, @cstore_X+Q, @_lit_X+Q, 1, @plus_X+Q
|
|
' r> 1 - >r _jmp _accept1
|
|
word @fromr_X+Q, @_lit_X+Q, 1, @minus_X+Q, @tor_X+Q, @_jmp_X+Q, @accept_1+Q, 0
|
|
long
|
|
|
|
' : refill tib 200 accept #tib ! 0 >in ! ;
|
|
refill_L word @accept_L+Q
|
|
byte FLAG_DEF, 6, "refill"
|
|
long
|
|
refill_X word execlistfunc, 0
|
|
word @tib_X+Q, @_lit_X+Q, 200, @accept_X+Q, @poundtib_X+Q, @store_X+Q, @_lit_X+Q, 0, @greaterin_X+Q, @store_X+Q, 0
|
|
long
|
|
|
|
' : compile, here w! 2 allot ;
|
|
compcomma_L word @refill_L+Q
|
|
byte FLAG_DEF, 8, "compile,"
|
|
long
|
|
compcomma_X word execlistfunc, 0
|
|
word @here_X+Q, @wstore_X+Q, @_lit_X+Q, 2, @allot_X+Q, 0
|
|
long
|
|
|
|
'*******************************************************************************
|
|
' The boot interpreter follows below.
|
|
'*******************************************************************************
|
|
' : xboot ( This word runs a simple interpreter )
|
|
xboot_L word @compcomma_L+Q
|
|
byte FLAG_DEF, 5, "xboot"
|
|
long
|
|
xboot_X word execlistfunc, 0
|
|
|
|
' 20 word 0 pick c@ _jz _xboot2 ( Get word, refill if empty )
|
|
xboot_1 word @_lit_X+Q, $20, @word_X+Q, @_lit_X+Q, 0, @pick_X+Q, @cfetch_X+Q, @_jz_X+Q, @xboot_2+Q
|
|
|
|
' find 0 pick _jz _xboot3 ( Find word, get number if not found )
|
|
word @find_X+Q, @_lit_X+Q, 0, @pick_X+Q, @_jz_X+Q, @xboot_3+Q
|
|
|
|
' state @ = _jz _xboot4 ( Go execute if not compile mode or immediate )
|
|
word @state_X+Q, @fetch_X+Q, @equal_X+Q, @_jz_X+Q, @xboot_4+Q
|
|
|
|
' compile, _jmp _xboot1 ( Otherwise, compile and loop again )
|
|
word @compcomma_X+Q, @_jmp_X+Q, @xboot_1+Q
|
|
|
|
' execute _jmp _xboot1 ( Execute and loop again )
|
|
xboot_4 word @execute_X+Q, @_jmp_X+Q, @xboot_1+Q
|
|
|
|
' drop count _gethex ( Get number )
|
|
xboot_3 word @drop_X+Q, @count_X+Q, @_gethex_X+Q
|
|
|
|
' state @ _jz _xboot1 ( Loop again if not compile mode )
|
|
word @state_X+Q, @fetch_X+Q, @_jz_X+Q, @xboot_1+Q
|
|
|
|
' ['] _lit , , _jmp _xboot1 ( Otherwise, compile number and loop again )
|
|
word @_lit_X+Q, @_lit_X+Q, @compcomma_X+Q, @compcomma_X+Q, @_jmp_X+Q, @xboot_1+Q
|
|
|
|
' drop refill _jmp _xboot1 ( Refill and loop again )
|
|
xboot_2 word @drop_X+Q, @refill_X+Q, @_lit_X+Q, 13, @emit_X+Q, @_jmp_X+Q, @xboot_1+Q, 0
|
|
long
|
|
|
|
switch_L word @xboot_L+Q
|
|
byte FLAG_DEF, 6, "switch"
|
|
long
|
|
switch_X word execlistfunc, 0
|
|
word @_lit_X+Q, @getchar_X+Q, @_lit_X+Q, @key_B+Q, @store_X+Q, 0
|
|
long
|
|
|
|
_last long
|
|
|
|
_loop_L word @switch_L+Q
|
|
byte FLAG_CORE, 5, "_loop"
|
|
long
|
|
_loop_X word _loopfunc, 0
|
|
|
|
_here long
|
|
|
|
'*******************************************************************************
|
|
' The Forth source files follow below. They will be compiled into the
|
|
' dictionary, which will over-write the source data. Some padding space is
|
|
' included to ensure that we don't over-write the source data before it is
|
|
' compiled.
|
|
'*******************************************************************************
|
|
long 0[100]
|
|
infile byte "1 verbose !", 13
|
|
file "init.fth"
|
|
file "comus.fth"
|
|
'file "see.fth"
|
|
'file "propwords.fth"
|
|
'file "bufser.fth"
|
|
'file "i2c.fth"
|
|
'file "fds.fth"
|
|
'file "time.fth"
|
|
'file "toggle.fth"
|
|
'file "primes.fth"
|
|
'byte 13, " 1 verbose !", 13
|
|
'byte " .s ", 13
|
|
'file "chess.fth"
|
|
|
|
'*******************************************************************************
|
|
' Enable serial output, print version string and switch to serial input
|
|
'*******************************************************************************
|
|
byte 13
|
|
byte " 1 verbose !"
|
|
byte " pfthversion type cr"
|
|
byte " switch", 13
|
|
|
|
|
|
{
|
|
+--------------------------------------------------------------------
|
|
| TERMS OF USE: MIT License
|
|
+--------------------------------------------------------------------
|
|
Permission is hereby granted, free of charge, to any person obtaining
|
|
a copy of this software and associated documentation files
|
|
(the "Software"), to deal in the Software without restriction,
|
|
including without limitation the rights to use, copy, modify, merge,
|
|
publish, distribute, sublicense, and/or sell copies of the Software,
|
|
and to permit persons to whom the Software is furnished to do so,
|
|
subject to the following conditions:
|
|
|
|
The above copyright notice and this permission notice shall be
|
|
included in all copies or substantial portions of the Software.
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
|
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
|
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
|
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
|
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
|
+------------------------------------------------------------------
|
|
} |