547 lines
11 KiB
Forth
547 lines
11 KiB
Forth
( 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
|