From a76977af62010a392c16010c367185e61e856ffe Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Wed, 30 Oct 2019 20:04:56 +0100 Subject: mv to docs --- j1demo/firmware/nuc.fs | 546 ------------------------------------------------- 1 file changed, 546 deletions(-) delete mode 100644 j1demo/firmware/nuc.fs (limited to 'j1demo/firmware/nuc.fs') diff --git a/j1demo/firmware/nuc.fs b/j1demo/firmware/nuc.fs deleted file mode 100644 index deadcc7..0000000 --- a/j1demo/firmware/nuc.fs +++ /dev/null @@ -1,546 +0,0 @@ -( 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 -- cgit v1.2.3