aboutsummaryrefslogtreecommitdiff
path: root/docs/j1demo/firmware/nuc.fs
diff options
context:
space:
mode:
Diffstat (limited to 'docs/j1demo/firmware/nuc.fs')
-rw-r--r--docs/j1demo/firmware/nuc.fs546
1 files changed, 546 insertions, 0 deletions
diff --git a/docs/j1demo/firmware/nuc.fs b/docs/j1demo/firmware/nuc.fs
new file mode 100644
index 0000000..deadcc7
--- /dev/null
+++ b/docs/j1demo/firmware/nuc.fs
@@ -0,0 +1,546 @@
+( Nucleus: ANS Forth core and ext words JCB 13:11 08/24/10)
+
+module[ nuc"
+
+32 constant sp
+0 constant false ( 6.2.1485 )
+: depth dsp h# ff and ;
+: true ( 6.2.2298 ) d# -1 ;
+: 1+ d# 1 + ;
+: rot >r swap r> swap ;
+: -rot swap >r swap r> ;
+: 0= d# 0 = ;
+: tuck swap over ;
+: 2drop drop drop ;
+: ?dup dup if dup then ;
+
+: split ( a m -- a&m a&~m )
+ over \ a m a
+ and \ a a&m
+ tuck \ a&m a a&m
+ xor \ a&m a&~m
+;
+
+: merge ( a b m -- m?b:a )
+ >r \ a b
+ over xor \ a a^b
+ r> and \ a (a^b)&m
+ xor \ ((a^b)&m)^a
+;
+
+: c@ dup @ swap d# 1 and if d# 8 rshift else d# 255 and then ;
+: c! ( u c-addr )
+ swap h# ff and dup d# 8 lshift or swap
+ tuck dup @ swap ( c-addr u v c-addr )
+ d# 1 and d# 0 = h# ff xor
+ merge swap !
+;
+: c!be d# 1 xor c! ;
+
+: looptest ( -- FIN )
+ r> ( xt )
+ r> ( xt i )
+ 1+
+ r@ over = ( xt i FIN )
+ dup if
+ nip r> drop
+ else
+ swap >r
+ then ( xt FIN )
+ swap
+ >r
+;
+
+\ Stack
+: 2dup over over ;
+: +! tuck @ + swap ! ;
+
+\ Comparisons
+: <> = invert ;
+: 0<> 0= invert ;
+: 0< d# 0 < ;
+: 0>= 0< invert ;
+: 0> d# 0 ;fallthru
+: > swap < ;
+: >= < invert ;
+: <= > invert ;
+: u> swap u< ;
+
+\ Arithmetic
+: negate invert 1+ ;
+: - negate + ;
+: abs dup 0< if negate then ;
+: min 2dup < ;fallthru
+: ?: ( xt xf f -- xt | xf) if drop else nip then ;
+: max 2dup > ?: ;
+code cells end-code
+code addrcells end-code
+: 2* d# 1 lshift ;
+code cell+ end-code
+code addrcell+ end-code
+: 2+ d# 2 + ;
+: 2- 1- 1- ;
+: 2/ d# 1 rshift ;
+: c+! tuck c@ + swap c! ;
+
+: count dup 1+ swap c@ ;
+: /string dup >r - swap r> + swap ;
+: aligned 1+ h# fffe and ;
+
+: sliteral
+ r>
+ count
+ 2dup
+ +
+ aligned
+;fallthru
+: execute >r ;
+
+: 15down down1 ;fallthru
+: 14down down1 ;fallthru
+: 13down down1 ;fallthru
+: 12down down1 ;fallthru
+: 11down down1 ;fallthru
+: 10down down1 ;fallthru
+: 9down down1 ;fallthru
+: 8down down1 ;fallthru
+: 7down down1 ;fallthru
+: 6down down1 ;fallthru
+: 5down down1 ;fallthru
+: 4down down1 ;fallthru
+: 3down down1 ;fallthru
+: 2down down1 ;fallthru
+: 1down down1 ;fallthru
+: 0down copy ;
+
+: 15up up1 ;fallthru
+: 14up up1 ;fallthru
+: 13up up1 ;fallthru
+: 12up up1 ;fallthru
+: 11up up1 ;fallthru
+: 10up up1 ;fallthru
+: 9up up1 ;fallthru
+: 8up up1 ;fallthru
+: 7up up1 ;fallthru
+: 6up up1 ;fallthru
+: 5up up1 ;fallthru
+: 4up up1 ;fallthru
+: 3up up1 ;fallthru
+: 2up up1 ;fallthru
+: 1up up1 ;fallthru
+: 0up ;
+
+code pickbody
+ copy return
+ 1down scall 1up ubranch
+ 2down scall 2up ubranch
+ 3down scall 3up ubranch
+ 4down scall 4up ubranch
+ 5down scall 5up ubranch
+ 6down scall 6up ubranch
+ 7down scall 7up ubranch
+ 8down scall 8up ubranch
+ 9down scall 9up ubranch
+ 10down scall 10up ubranch
+ 11down scall 11up ubranch
+ 12down scall 12up ubranch
+ 13down scall 13up ubranch
+ 14down scall 14up ubranch
+ 15down scall 15up ubranch
+end-code
+
+: pick
+ dup 2* 2* ['] pickbody + execute ;
+
+: swapdown
+ ]asm
+ N T->N alu
+ T d-1 alu
+ asm[
+;
+: swapdowns
+ swapdown swapdown swapdown swapdown
+ swapdown swapdown swapdown swapdown
+ swapdown swapdown swapdown swapdown
+ swapdown swapdown swapdown swapdown ;fallthru
+: swapdown0 ;
+: roll
+ 2*
+ ['] 0up over - >r
+ ['] swapdown0 swap - execute
+;
+
+\ ========================================================================
+\ Double
+\ ========================================================================
+
+: d= ( a b c d -- f )
+ >r \ a b c
+ rot xor \ b a^c
+ swap r> xor \ a^c b^d
+ or 0=
+;
+
+: 2@ ( ptr -- lo hi )
+ dup @ swap 2+ @
+;
+
+: 2! ( lo hi ptr -- )
+ rot over \ hi ptr lo ptr
+ ! 2+ !
+;
+
+: 2over >r >r 2dup r> r> ;fallthru
+: 2swap rot >r rot r> ;
+: 2nip rot drop rot drop ;
+: 2rot ( d1 d2 d3 -- d2 d3 d1 ) 2>r 2swap 2r> 2swap ;
+: 2pick
+ 2* 1+ dup 1+ \ lo hi ... 2k+1 2k+2
+ pick \ lo hi ... 2k+1 lo
+ swap \ lo hi ... lo 2k+1
+ pick \ lo hi ... lo hi
+;
+
+
+: d+ ( augend . addend . -- sum . )
+ rot + >r ( augend addend)
+ over + ( augend sum)
+ dup rot ( sum sum augend)
+ u< if ( sum)
+ r> 1+
+ else
+ r>
+ then ( sum . )
+;
+
+: +h ( u1 u2 -- u1+u2/2**16 )
+ over + ( a a+b )
+ u> d# 1 and
+;
+
+: +1c \ one's complement add, as in TCP checksum
+ 2dup +h + +
+;
+
+: s>d dup 0< ;
+: d1+ d# 1. d+ ;
+: dnegate
+ invert swap invert swap
+ d1+
+;
+: DABS ( d -- ud ) ( 8.6.1.1160 ) DUP 0< IF DNEGATE THEN ;
+
+: d- dnegate d+ ;
+
+\ Write zero to double
+: dz d# 0 dup rot 2! ;
+
+: dxor \ ( a b c d -- e f )
+ rot xor \ a c b^d
+ -rot xor \ b^d a^c
+ swap
+;
+
+: dand rot and -rot and swap ;
+: dor rot or -rot or swap ;
+
+: dinvert invert swap invert swap ;
+: d< \ ( al ah bl bh -- flag )
+ rot \ al bl bh ah
+ 2dup =
+ if
+ 2drop u<
+ else
+ 2nip >
+ then
+;
+
+: d> 2swap d< ;
+: d0<= d# 0. ;fallthru
+: d<= d> invert ;
+: d>= d< invert ;
+: d0= or 0= ;
+: d0< d# 0. d< ;
+: d0<> d0= invert ;
+: d<> d= invert ;
+: d2* 2dup d+ ;
+: d2/ dup d# 15 lshift >r 2/ swap 2/ r> or swap ;
+: dmax 2over 2over d< if 2swap then 2drop ;
+
+: d1- d# -1. d+ ;
+
+: d+! ( v. addr -- )
+ dup >r
+ 2@
+ d+
+ r>
+ 2!
+;
+
+: move ( addr1 addr2 u -- )
+ d# 0 do
+ over @ over !
+ 2+ swap 2+ swap
+ loop
+ 2drop
+;
+
+: cmove ( c-addr1 c-addr2 u -- )
+ d# 0 do
+ over c@ over c!
+ 1+ swap 1+ swap
+ loop
+ 2drop
+;
+
+: bounds ( a n -- a+n a ) OVER + SWAP ;
+: fill ( c-addr u char -- ) ( 6.1.1540 )
+ >R bounds
+ BEGIN 2dupxor
+ WHILE R@ OVER C! 1+
+ REPEAT R> DROP 2DROP ;
+
+\ Math
+
+0 [IF]
+create scratch d# 2 allot
+: um* ( u1 u2 -- ud )
+ scratch !
+ d# 0.
+ d# 16 0do
+ 2dup d+
+ rot dup 0< if
+ 2* -rot
+ scratch @ d# 0 d+
+ else
+ 2* -rot
+ then
+ loop
+ rot drop
+;
+[ELSE]
+: um* mult_a ! mult_b ! mult_p 2@ ;
+[THEN]
+
+: * um* drop ;
+: abssgn ( a b -- |a| |b| negf )
+ 2dup xor 0< >r abs swap abs swap r> ;
+
+: m* abssgn >r um* r> if dnegate then ;
+
+: divstep
+ ( divisor dq hi )
+ 2*
+ over 0< if 1+ then
+ swap 2* swap
+ rot ( dq hi divisor )
+ 2dup >= if
+ tuck ( dq divisor hi divisor )
+ -
+ swap ( dq hi divisor )
+ rot 1+ ( hi divisor dq )
+ rot ( divisor dq hi )
+ else
+ -rot
+ then
+ ;
+
+: um/mod ( ud u1 -- u2 u3 ) ( 6.1.2370 )
+ -rot
+ divstep divstep divstep divstep
+ divstep divstep divstep divstep
+ divstep divstep divstep divstep
+ divstep divstep divstep divstep
+ rot drop swap
+;
+
+: /mod >R S>D R> ;fallthru
+: SM/REM ( d n -- r q ) ( 6.1.2214 ) ( symmetric )
+ OVER >R >R DABS R@ ABS UM/MOD
+ R> R@ XOR 0< IF NEGATE THEN R> 0< IF >R NEGATE R> THEN ;
+: / /mod nip ;
+: mod /mod drop ;
+: */mod >R M* R> SM/REM ;
+: */ */mod nip ;
+
+: t2* over >r >r d2*
+ r> 2* r> 0< d# 1 and + ;
+
+variable divisor
+: m*/mod
+ divisor !
+ tuck um* 2swap um* ( hi. lo. )
+ ( m0 h l m1 )
+ swap >r d# 0 d+ r> ( m h l )
+ -rot ( l m h )
+ d# 32 0do
+ t2*
+ dup divisor @ >= if
+ divisor @ -
+ rot 1+ -rot
+ then
+ loop
+;
+: m*/ m*/mod drop ;
+
+
+\ Numeric output - from eforth
+
+variable base
+variable hld
+create pad 84 allot create pad|
+
+: <# ( -- ) ( 6.1.0490 )( h# 96 ) pad| HLD ! ;
+: DIGIT ( u -- c ) d# 9 OVER < d# 7 AND + [CHAR] 0 + ;
+: HOLD ( c -- ) ( 6.1.1670 ) HLD @ 1- DUP HLD ! C! ;
+
+: # ( d -- d ) ( 6.1.0030 )
+ d# 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ;
+
+: #S ( d -- d ) ( 6.1.0050 ) BEGIN # 2DUP OR 0= UNTIL ;
+: #> ( d -- a u ) ( 6.1.0040 ) 2DROP HLD @ pad| OVER - ;
+
+: SIGN ( n -- ) ( 6.1.2210 ) 0< IF [CHAR] - HOLD THEN ;
+
+\ hex(int((1<<24) * (115200 / 2400.) / (WB_CLOCK_FREQ / 2400.)))
+\ d# 42000000 constant WB_CLOCK_FREQ
+
+[ 48000000 17 12 */ ] constant WB_CLOCK_FREQ
+
+0 [IF]
+: uartbase
+ [ $100000000. 115200 WB_CLOCK_FREQ m*/ drop $ffffff00 and dup swap 16 rshift ] 2literal
+;
+: emit-uart
+ begin uart_0 @ 0= until
+ s>d
+ uartbase dor
+ uart_1 ! uart_0 !
+;
+[ELSE]
+: emit-uart drop ;
+[THEN]
+
+create 'emit
+meta emit-uart t, target
+
+: emit 'emit @ execute ;
+: cr d# 13 emit d# 10 emit ;
+d# 32 constant bl
+: space bl emit ;
+: spaces begin dup 0> while space 1- repeat drop ;
+
+: hex1 d# 15 and dup d# 10 < if d# 48 else d# 55 then + emit ;
+: hex2
+ dup
+ d# 4 rshift
+ hex1 hex1
+;
+: hex4
+ dup
+ d# 8 rshift
+ hex2 hex2 ;
+
+: hex8 hex4 hex4 ;
+
+: type
+ d# 0 do
+ dup c@ emit
+ 1+
+ loop
+ drop
+;
+
+: dump
+ ( addr u )
+ 0do
+ dup d# 15 and 0= if dup cr hex4 [char] : emit space space then
+ dup c@ hex2 space 1+
+ loop
+ cr drop
+;
+
+: dump16
+ ( addr u )
+ 0do
+ dup hex4 [char] : emit space dup @ hex4 cr 2+
+ loop
+ drop
+;
+
+: decimal d# 10 base ! ;
+: hex d# 16 base ! ;
+
+: S.R ( a u n -- ) OVER - SPACES TYPE ;
+: D.R ( d n -- ) ( 8.6.1.1070 ) >R DUP >R DABS <# #S R> SIGN #> R> S.R ;
+: U.R ( u n -- ) ( 6.2.2330 ) d# 0 SWAP D.R ;
+: .R ( n n -- ) ( 6.2.0210 ) >R S>D R> D.R ;
+
+: D. ( d -- ) ( 8.6.1.1060 ) d# 0 D.R SPACE ;
+: U. ( u -- ) ( 6.1.2320 ) d# 0 D. ;
+: . ( n -- ) ( 6.1.0180 ) BASE @ d# 10 XOR IF U. EXIT THEN S>D D. ;
+: ? ( a -- ) ( 15.6.1.0600 ) @ . ;
+
+( Numeric input )
+
+: DIGIT? ( c base -- u f ) ( 0xA3 )
+ >R [CHAR] 0 - D# 9 OVER <
+ IF D# 7 - DUP D# 10 < OR THEN DUP R> U< ;
+
+: >number ( ud a u -- ud a u ) ( 6.1.0570 )
+ begin
+ dup 0= if exit then
+ over c@ base @ digit? if
+ >r 2swap
+ drop base @ um*
+ r> s>d d+ 2swap
+ d# 1 /string >number
+ else
+ drop exit
+ then
+ again
+;
+
+: .s
+ [char] < emit
+ depth dup hex2
+ [char] > emit
+
+ d# 8 min
+ ?dup if
+ 0do
+ i pick hex4 space
+ loop
+ then
+;
+
+build-debug? [IF]
+: (assert)
+ s" **** ASSERTION FAILED **** " type
+ ;fallthru
+: (snap)
+ type space
+ s" LINE " type
+ .
+ [char] : emit
+ space
+ .s
+ cr
+;
+[THEN]
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+
+: endian dup d# 8 lshift swap d# 8 rshift or ;
+: 2endian endian swap endian ;
+: swab endian ;
+: typepad ( c-addr u w ) over - >r type r> spaces ;
+: even? d# 1 and 0= ;
+
+\ rise? and fall? act like ! - except that they leave a true
+\ if the value rose or fell, respectively.
+
+: rise? ( u a -- f ) 2dup @ u> >r ! r> ;
+: fall? ( u a -- f ) 2dup @ u< >r ! r> ;
+
+]module