aboutsummaryrefslogtreecommitdiff
path: root/forth
diff options
context:
space:
mode:
authorDimitri Sokolyuk <demon@dim13.org>2018-09-21 22:44:31 +0200
committerDimitri Sokolyuk <demon@dim13.org>2018-09-21 22:44:31 +0200
commita7ac30a16cb4e2338ded87235deb352c1055da16 (patch)
treee0afce2adbe7eba8b5fc8b80b20491548229c9d5 /forth
parent55aa48a0137694efcf11ed66070690589596d2aa (diff)
add core.fs
Diffstat (limited to 'forth')
-rw-r--r--forth/core.fs450
-rwxr-xr-xforth/ff-shell.tcl10
2 files changed, 453 insertions, 7 deletions
diff --git a/forth/core.fs b/forth/core.fs
new file mode 100644
index 0000000..511288d
--- /dev/null
+++ b/forth/core.fs
@@ -0,0 +1,450 @@
+\ Some extra core words
+
+-core
+marker -core
+hex ram
+
+\ Interpret a string. The string must be in ram
+: evaluate ( caddr n -- )
+ 'source 2@ >r >r >in @ >r
+ interpret
+ r> >in ! r> r> 'source 2!
+;
+
+: forget ( --- name )
+ bl word latest @ (f) ?abort?
+ c>n 2- dup @ ?abort?
+ dup flash dp ! @ latest ! ram
+;
+
+ ( addr n c -- ) \ fill addr to addr+n with c
+: fill rot !p>r swap for dup pc! p+ next r>p drop ;
+
+\ addr n --
+: erase 0 fill ;
+
+\ addr n --
+: blanks bl fill ;
+
+\ x -- 0 | x x
+: ?dup dup if inline dup then ;
+
+\ nfa -- flag
+: in? c@ $40 and ;
+
+\ addr -- addr+1 n
+: count c@+ ;
+
+\ MCU with eeprom
+: .free
+ cr ." Flash:" flash hi here - u. ." bytes"
+ cr ." Eeprom:" eeprom hi here - u. ." bytes"
+ cr ." Ram:" ram hi here - u. ." bytes"
+;
+
+\ xu ... x0 u -- xu ... x0 xu
+: pick 2* sp@ + @ ;
+
+-see
+marker -see
+hex ram
+: *@ dup @ ;
+: u.4 4 u.r ;
+: *@+ dup cell+ @ u.4 ;
+: 5sp 5 spaces ;
+: @braddr ( addr -- addr xt-addr )
+ *@ fff and dup 800 and
+ if f800 or then 2* over + cell+ ;
+: @xtaddr ( addr -- addr xt-addr )
+ dup cell+ @ xa> ;
+: .rjmp ( addr -- addr+2 ) @braddr u.4 cell+ ;
+: .br ( addr -- addr+2 )
+ *@ 3 rshift 7f and dup 40 and
+ if ff80 or then 2* over + cell+ u.4 cell+ ;
+: .reg ( addr -- addr )
+ dup @ 4 rshift 1f and ." r" decimal 2 u.r hex cell+ ;
+: .ldi ( addr -- addr )
+ *@ dup 4 rshift dup 000f and 0010 +
+ ." r" decimal 2 u.r hex
+ 00f0 and swap 000f and + 2 u.r cell+ ;
+: ?call ( addr -- addr f ) *@ fe0e and 940e - ;
+: ?ret ( addr -- addr f ) *@ 9508 - ;
+: ?rcall ( addr -- addr f ) *@ f000 and d000 - ;
+: ?jmp ( addr -- addr f ) *@ fe0e and 940c - ;
+: ?rjmp ( addr -- addr f ) *@ f000 and c000 - ;
+: ?breq ( addr -- addr f ) *@ fc07 and f001 - ;
+: ?brne ( addr -- addr f ) *@ fc07 and f401 - ;
+: ?brcc ( addr -- addr f ) *@ fc07 and f400 - ;
+: ?pop ( addr -- addr f ) *@ fe0f and 900f - ;
+: ?push ( addr -- addr f ) *@ fe0f and 920f - ;
+: ?st-y ( addr -- addr f ) *@ fe0f and 920a - ;
+: ?ldy+ ( addr -- addr f ) *@ fe0f and 9009 - ;
+: ?ijmp ( addr -- addr f ) *@ 9409 - ;
+: ?ldi ( addr -- addr f ) *@ f000 and e000 - ;
+: (see) ( addr -- addr' | false )
+ dup u.4
+ *@ u.4
+ ?call 0= if *@+ ." call " @xtaddr c>n .id cell+ cell+ else
+ ?rcall 0= if 5sp ." rcall " @braddr c>n .id cell+ else
+ ?breq 0= if 5sp ." breq " .br else
+ ?brne 0= if 5sp ." brne " .br else
+ ?brcc 0= if 5sp ." brcc " .br else
+ ?rjmp 0= if 5sp ." rjmp " .rjmp else
+ ?ijmp 0= if 5sp ." ijmp" drop false else
+ ?ret 0= if 5sp ." ret" drop false else
+ ?jmp 0= if *@+ ." jmp " @xtaddr c>n .id drop false else
+ ?pop 0= if 5sp ." pop " .reg else
+ ?push 0= if 5sp ." push " .reg else
+ ?ldy+ 0= if 5sp ." ld " .reg ." y+" else
+ ?st-y 0= if 5sp ." st -y " .reg else
+ ?ldi 0= if 5sp ." ldi " .ldi else
+ cell+
+ then then then then then
+ then then then then then
+ then then then then
+ cr ;
+
+: dis ( addr -- )
+ hex cr
+ begin (see) dup 0=
+ until drop ;
+
+: see ( "word" -- ) ' dis ;
+hex ram
+
+-doloop
+marker -doloop
+
+: compileonly $10 shb ;
+
+#20 constant ind inlined \ R18:R19 are unused by the kernel
+
+: (do) ( limit index -- R: leave oldindex xfaxtor )
+ r>
+ dup >a xa> @ >r \ R: leave
+ ind @ >r \ R: leave oldindex
+ swap $8000 swap - dup >r \ R: leave oldindex xfactor
+ + ind !
+ a> 1+ >r
+; compileonly
+
+: (?do) ( limit index -- R: leave oldindex xfactor )
+ 2dup xor
+ if
+ [ ' (do) ] again \ branch to (do)
+ then
+ r> xa> @ >r 2drop
+; compileonly
+
+: (+loop) ( n -- )
+ [ $0f48 i, ] \ add r20, tosl
+ [ $1f59 i, ] \ add r21, tosh
+ inline drop
+; compileonly
+
+: unloop
+ r>
+ rdrop r> ind ! rdrop
+ >r
+; compileonly
+
+: do
+ postpone (do)
+ postpone begin
+ flash 2 allot ram \ leave address
+ postpone begin
+; immediate compileonly
+
+: ?do
+ postpone (?do)
+ postpone begin
+ flash 2 allot ram \ leave address
+ postpone begin
+; immediate compileonly
+
+: leave
+ rdrop rdrop r> ind !
+; compileonly
+
+: i
+ ind @ rp@ 3 + @ >< -
+; compileonly
+
+: j
+ rp@ 5 + @ >< rp@ 9 + @ >< -
+; compileonly
+
+
+: loop
+ $0d46 i, $1d55 i, \ add 1 to r20:r21
+\ postpone (loop)
+ $f00b i, \ bra +2 if overflow
+ postpone again
+ postpone unloop
+ flash here >xa swap ! ram
+; immediate compileonly
+
+: +loop
+ postpone (+loop)
+ $f00b i, \ bra +2 if overflow
+ postpone again
+ postpone unloop
+ flash here >xa swap ! ram
+; immediate compileonly
+
+-bit
+marker -bit
+: (bio) ( c-addr -- in/out-addr ) $20 - dup $5 lshift or $60f and ;
+: (bit) ( c-addr bit flag "name" -- )
+ : >r
+ over $40 < if
+ swap $20 - 3 lshift or
+ r>
+ if $9a00 \ sbi io-addr, bit
+ else $9800 \ cbi io-addr, bit
+ then or i,
+ else
+ over $60 <
+ if over (bio) $b100 or \ in r16 io-addr
+ else $9100 i, over \ lds r16 c-addr
+ then i,
+ 1 swap lshift
+ r>
+ if $6000 >r
+ else $7000 >r invert $ff and
+ then dup 4 lshift or $f0f and r> or i, \ andi/ori r16, mask
+ dup $60 <
+ if (bio) $b900 or \ out io-addr r16
+ else $9300 i, \ sts c-addr r16
+ then i,
+ then
+ $9508 i, \ return
+ postpone [
+;
+
+\ Define a word that clears a bit in ram
+\ The defined word can be inlined
+( c-addr bit "name" -- )
+: bit0: false (bit) ;
+
+\ Define a word that sets a bit in ram
+\ The defined word can be inlined
+( c-addr bit "name" -- )
+: bit1: true (bit) ;
+
+\ Define a word that leaves a true flag if a bit in ram is one
+\ and a false flag if a bit is zero.
+\ The defined word can be inlined
+( c-addr bit "name" -- )
+: bit?:
+ :
+ $939a i, $938a i, $ef8f i, $ef9f i, \ true
+ over $40 < if
+ swap $20 - 3 lshift or $9b00 or i, \ sbis io-addr, bit
+ else
+ over $60 <
+ if swap (bio) $b100 or \ in r16 io-addr
+ else $9100 i, swap \ lds r16 c-addr
+ then i, $ff00 or i, \ sbrs r16, bit
+ then
+ $9601 i, \ 1+
+ $9508 i, \ return
+ postpone [
+;
+
+-task
+marker -task
+hex ram
+
+\ Near definition saves memory !
+: up! up ! ;
+: up@ up @ ;
+: op@ operator @ ;
+: ul@ ulink @ ;
+: ul! ulink ! ;
+: op! op@ up! ;
+\ access user variables of other task
+: his ( task-addr var-addr -- addr )
+ up@ - swap @ +
+;
+
+\ Define a new task
+\ A new task must be defined in the flash memory space
+: task: ( tibsize stacksize rsize addsize -- )
+ flash create
+ up@ s0 - dup \ Basic size ts ss rs as bs bs
+ ram here + flash , \ User pointer ts ss rs as bs
+ 4 for
+ over , +
+ next
+ cell+ \ Task size
+ ram allot
+;
+
+\ Initialise a user area and link it to the task loop
+\ May only be executed from the operator task
+: tinit ( taskloop-addr task-addr -- )
+ \ use task user area
+ @+ up! \ a addsize-addr
+ ul@ if \ ? Already running
+ 2drop
+ else
+ \ Pointer to task area
+ dup 2- task !
+ \ r0 = uarea+addsize+rsize
+ @+ swap @+ rot + up@ + \ a ssize-addr r0
+ \ Save r0
+ r0 ! \ a ssize-addr
+ \ s0 = r0 + ssize
+ @ r0 @ + s0 ! \ a
+ \ Store task-loop address to the return stack
+ r0 @ x>r \ rsp
+ \ Store SP to return stack
+ 1- dup s0 @ swap ! \ rsp
+ \ Store current rsp and space for saving TOS and P PAUSE
+ 5 - rsave ! \
+ \ tiu = s0 + 2
+ s0 @ 2+ tiu !
+ 0 ul!
+ 0 task 2+ ! \ clear status and cr flag
+ decimal \ Set the base to decimal
+ then
+ op! \ run the operator task again
+;
+
+\ Insert a new task after operator in the linked list.
+\ May only be executed from the operator task
+: run ( task-addr -- )
+ @ up! ul@ 0= if \ ? Already running
+ up@ \ task-uarea
+ op! ul@ \ task-uarea operator-ulink
+ over ul!
+ swap up! ul!
+ then
+ op! \ run operator task
+;
+
+\ End a task by linking it out from the linked list
+\ May only be executed from the operator task
+: end ( task-addr -- )
+ @ up! ul@ if
+ up@
+ op!
+ begin \ find the uarea in the linked list
+ dup ul@ <> \ uarea flag
+ while
+ ul@ up! \ uarea
+ repeat
+ up@ \ uarea prev-uarea
+ swap up! \ prev-uarea
+ ul@ \ prev-uarea next-uarea
+ 0 ul! \ ulink of a ended task is zero
+ swap up! \ next-uarea
+ ul! \
+ then
+ op!
+;
+
+\ End all tasks except the operator task
+\ May only be executed from the operator task
+: single ( -- )
+ ul@ op@ <> if \ Are there any running tasks
+ ul@ op@ ul! \ link operator to himself
+ up! \ move to next user area
+ begin
+ ul@ op@ <> \ is this the last linked user area
+ while
+ ul@ 0 ul! \ write zero to ulink
+ up! \ and move to next user area
+ repeat
+ 0 ul!
+ op!
+ then
+;
+
+\ List all running tasks
+: tasks ( -- )
+ up@ op!
+ begin
+ up@
+ task @ 6 - op! c>n .id space
+ up!
+ ul@ op@ -
+ while
+ ul@ up!
+ repeat
+ up!
+;
+
+-io
+marker -io
+
+\ TIMER_COUNTER_1
+$6f constant TIMSK1 \ Timer/Counter Interrupt Mask Register
+$36 constant TIFR1 \ Timer/Counter Interrupt Flag register
+$80 constant TCCR1A \ Timer/Counter1 Control Register A
+$81 constant TCCR1B \ Timer/Counter1 Control Register B
+$82 constant TCCR1C \ Timer/Counter1 Control Register C
+$84 constant TCNT1 \ Timer/Counter1 Bytes
+$88 constant OCR1A \ Timer/Counter1 Output Compare Register Bytes
+$8a constant OCR1B \ Timer/Counter1 Output Compare Register Bytes
+$86 constant ICR1 \ Timer/Counter1 Input Capture Register Bytes
+$43 constant GTCCR \ General Timer/Counter Control Register
+
+\ TIMER_COUNTER_2
+$70 constant TIMSK2 \ Timer/Counter Interrupt Mask register
+$37 constant TIFR2 \ Timer/Counter Interrupt Flag Register
+$b0 constant TCCR2A \ Timer/Counter2 Control Register A
+$b1 constant TCCR2B \ Timer/Counter2 Control Register B
+$b2 constant TCNT2 \ Timer/Counter2
+$b4 constant OCR2B \ Timer/Counter2 Output Compare Register B
+$b3 constant OCR2A \ Timer/Counter2 Output Compare Register A
+$b6 constant ASSR \ Asynchronous Status Register
+
+\ AD_CONVERTER
+$7c constant ADMUX \ The ADC multiplexer Selection Register
+$78 constant ADC \ ADC Data Register Bytes
+$7a constant ADCSRA \ The ADC Control and Status register A
+$7b constant ADCSRB \ The ADC Control and Status register B
+$7e constant DIDR0 \ Digital Input Disable Register
+
+\ ANALOG_COMPARATOR
+$50 constant ACSR \ Analog Comparator Control And Status Register
+$7f constant DIDR1 \ Digital Input Disable Register 0x1
+
+\ PORTB
+$25 constant PORTB \ Port B Data Register
+$24 constant DDRB \ Port B Data Direction Register
+$23 constant PINB \ Port B Input Pins
+
+\ PORTC
+$28 constant PORTC \ Port C Data Register
+$27 constant DDRC \ Port C Data Direction Register
+$26 constant PINC \ Port C Input Pins
+
+\ PORTD
+$2b constant PORTD \ Port D Data Register
+$2a constant DDRD \ Port D Data Direction Register
+$29 constant PIND \ Port D Input Pins
+
+\ TIMER_COUNTER_0
+$48 constant OCR0B \ Timer/Counter0 Output Compare Register
+$47 constant OCR0A \ Timer/Counter0 Output Compare Register
+$46 constant TCNT0 \ Timer/Counter0
+$45 constant TCCR0B \ Timer/Counter Control Register B
+$44 constant TCCR0A \ Timer/Counter Control Register A
+$6e constant TIMSK0 \ Timer/Counter0 Interrupt Mask Register
+$35 constant TIFR0 \ Timer/Counter0 Interrupt Flag register
+
+\ EXTERNAL_INTERRUPT
+$69 constant EICRA \ External Interrupt Control Register
+$3d constant EIMSK \ External Interrupt Mask Register
+$3c constant EIFR \ External Interrupt Flag Register
+$68 constant PCICR \ Pin Change Interrupt Control Register
+$6d constant PCMSK2 \ Pin Change Mask Register 0x2
+$6c constant PCMSK1 \ Pin Change Mask Register 0x1
+$6b constant PCMSK0 \ Pin Change Mask Register 0x0
+$3b constant PCIFR \ Pin Change Interrupt Flag Register
+
+-main
+marker -main
diff --git a/forth/ff-shell.tcl b/forth/ff-shell.tcl
index 4fd1ae3..1aca0cb 100755
--- a/forth/ff-shell.tcl
+++ b/forth/ff-shell.tcl
@@ -62,11 +62,10 @@ set ::dataBits 8; # 7 8
set ::stopBits 1; # 1 2
set ::parityAndBits "$::parity,$::dataBits,$::stopBits"
set ::handShake xonxoff; # none xonxoff rtscts
-if { [string equal $::tcl_platform(platform) windows] } {
- console show
- set ::serialPortName {\\.\com5}
-} else {
+if { [string equal $::tcl_platform(os) Linux] } {
set ::serialPortName "/dev/ttyACM0"
+} else {
+ set ::serialPortName "/dev/cuaU0"
}; # end if
set ::portState closed
@@ -131,9 +130,6 @@ proc openSerialPort {} {
chan configure $::tty -mode $::baudRate,$::parityAndBits -timeout 10 \
-encoding binary -translation binary -handshake $::handShake \
-buffering none -buffersize 8192 -blocking false
- if { [string equal $::tcl_platform(platform) windows] } {
- chan configure $::tty -sysbuffer 8192
- }
chan event $::tty readable [list serialIn $::tty]
set ::portState open
}