nuc.fs 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546
  1. ( Nucleus: ANS Forth core and ext words JCB 13:11 08/24/10)
  2. module[ nuc"
  3. 32 constant sp
  4. 0 constant false ( 6.2.1485 )
  5. : depth dsp h# ff and ;
  6. : true ( 6.2.2298 ) d# -1 ;
  7. : 1+ d# 1 + ;
  8. : rot >r swap r> swap ;
  9. : -rot swap >r swap r> ;
  10. : 0= d# 0 = ;
  11. : tuck swap over ;
  12. : 2drop drop drop ;
  13. : ?dup dup if dup then ;
  14. : split ( a m -- a&m a&~m )
  15. over \ a m a
  16. and \ a a&m
  17. tuck \ a&m a a&m
  18. xor \ a&m a&~m
  19. ;
  20. : merge ( a b m -- m?b:a )
  21. >r \ a b
  22. over xor \ a a^b
  23. r> and \ a (a^b)&m
  24. xor \ ((a^b)&m)^a
  25. ;
  26. : c@ dup @ swap d# 1 and if d# 8 rshift else d# 255 and then ;
  27. : c! ( u c-addr )
  28. swap h# ff and dup d# 8 lshift or swap
  29. tuck dup @ swap ( c-addr u v c-addr )
  30. d# 1 and d# 0 = h# ff xor
  31. merge swap !
  32. ;
  33. : c!be d# 1 xor c! ;
  34. : looptest ( -- FIN )
  35. r> ( xt )
  36. r> ( xt i )
  37. 1+
  38. r@ over = ( xt i FIN )
  39. dup if
  40. nip r> drop
  41. else
  42. swap >r
  43. then ( xt FIN )
  44. swap
  45. >r
  46. ;
  47. \ Stack
  48. : 2dup over over ;
  49. : +! tuck @ + swap ! ;
  50. \ Comparisons
  51. : <> = invert ;
  52. : 0<> 0= invert ;
  53. : 0< d# 0 < ;
  54. : 0>= 0< invert ;
  55. : 0> d# 0 ;fallthru
  56. : > swap < ;
  57. : >= < invert ;
  58. : <= > invert ;
  59. : u> swap u< ;
  60. \ Arithmetic
  61. : negate invert 1+ ;
  62. : - negate + ;
  63. : abs dup 0< if negate then ;
  64. : min 2dup < ;fallthru
  65. : ?: ( xt xf f -- xt | xf) if drop else nip then ;
  66. : max 2dup > ?: ;
  67. code cells end-code
  68. code addrcells end-code
  69. : 2* d# 1 lshift ;
  70. code cell+ end-code
  71. code addrcell+ end-code
  72. : 2+ d# 2 + ;
  73. : 2- 1- 1- ;
  74. : 2/ d# 1 rshift ;
  75. : c+! tuck c@ + swap c! ;
  76. : count dup 1+ swap c@ ;
  77. : /string dup >r - swap r> + swap ;
  78. : aligned 1+ h# fffe and ;
  79. : sliteral
  80. r>
  81. count
  82. 2dup
  83. +
  84. aligned
  85. ;fallthru
  86. : execute >r ;
  87. : 15down down1 ;fallthru
  88. : 14down down1 ;fallthru
  89. : 13down down1 ;fallthru
  90. : 12down down1 ;fallthru
  91. : 11down down1 ;fallthru
  92. : 10down down1 ;fallthru
  93. : 9down down1 ;fallthru
  94. : 8down down1 ;fallthru
  95. : 7down down1 ;fallthru
  96. : 6down down1 ;fallthru
  97. : 5down down1 ;fallthru
  98. : 4down down1 ;fallthru
  99. : 3down down1 ;fallthru
  100. : 2down down1 ;fallthru
  101. : 1down down1 ;fallthru
  102. : 0down copy ;
  103. : 15up up1 ;fallthru
  104. : 14up up1 ;fallthru
  105. : 13up up1 ;fallthru
  106. : 12up up1 ;fallthru
  107. : 11up up1 ;fallthru
  108. : 10up up1 ;fallthru
  109. : 9up up1 ;fallthru
  110. : 8up up1 ;fallthru
  111. : 7up up1 ;fallthru
  112. : 6up up1 ;fallthru
  113. : 5up up1 ;fallthru
  114. : 4up up1 ;fallthru
  115. : 3up up1 ;fallthru
  116. : 2up up1 ;fallthru
  117. : 1up up1 ;fallthru
  118. : 0up ;
  119. code pickbody
  120. copy return
  121. 1down scall 1up ubranch
  122. 2down scall 2up ubranch
  123. 3down scall 3up ubranch
  124. 4down scall 4up ubranch
  125. 5down scall 5up ubranch
  126. 6down scall 6up ubranch
  127. 7down scall 7up ubranch
  128. 8down scall 8up ubranch
  129. 9down scall 9up ubranch
  130. 10down scall 10up ubranch
  131. 11down scall 11up ubranch
  132. 12down scall 12up ubranch
  133. 13down scall 13up ubranch
  134. 14down scall 14up ubranch
  135. 15down scall 15up ubranch
  136. end-code
  137. : pick
  138. dup 2* 2* ['] pickbody + execute ;
  139. : swapdown
  140. ]asm
  141. N T->N alu
  142. T d-1 alu
  143. asm[
  144. ;
  145. : swapdowns
  146. swapdown swapdown swapdown swapdown
  147. swapdown swapdown swapdown swapdown
  148. swapdown swapdown swapdown swapdown
  149. swapdown swapdown swapdown swapdown ;fallthru
  150. : swapdown0 ;
  151. : roll
  152. 2*
  153. ['] 0up over - >r
  154. ['] swapdown0 swap - execute
  155. ;
  156. \ ========================================================================
  157. \ Double
  158. \ ========================================================================
  159. : d= ( a b c d -- f )
  160. >r \ a b c
  161. rot xor \ b a^c
  162. swap r> xor \ a^c b^d
  163. or 0=
  164. ;
  165. : 2@ ( ptr -- lo hi )
  166. dup @ swap 2+ @
  167. ;
  168. : 2! ( lo hi ptr -- )
  169. rot over \ hi ptr lo ptr
  170. ! 2+ !
  171. ;
  172. : 2over >r >r 2dup r> r> ;fallthru
  173. : 2swap rot >r rot r> ;
  174. : 2nip rot drop rot drop ;
  175. : 2rot ( d1 d2 d3 -- d2 d3 d1 ) 2>r 2swap 2r> 2swap ;
  176. : 2pick
  177. 2* 1+ dup 1+ \ lo hi ... 2k+1 2k+2
  178. pick \ lo hi ... 2k+1 lo
  179. swap \ lo hi ... lo 2k+1
  180. pick \ lo hi ... lo hi
  181. ;
  182. : d+ ( augend . addend . -- sum . )
  183. rot + >r ( augend addend)
  184. over + ( augend sum)
  185. dup rot ( sum sum augend)
  186. u< if ( sum)
  187. r> 1+
  188. else
  189. r>
  190. then ( sum . )
  191. ;
  192. : +h ( u1 u2 -- u1+u2/2**16 )
  193. over + ( a a+b )
  194. u> d# 1 and
  195. ;
  196. : +1c \ one's complement add, as in TCP checksum
  197. 2dup +h + +
  198. ;
  199. : s>d dup 0< ;
  200. : d1+ d# 1. d+ ;
  201. : dnegate
  202. invert swap invert swap
  203. d1+
  204. ;
  205. : DABS ( d -- ud ) ( 8.6.1.1160 ) DUP 0< IF DNEGATE THEN ;
  206. : d- dnegate d+ ;
  207. \ Write zero to double
  208. : dz d# 0 dup rot 2! ;
  209. : dxor \ ( a b c d -- e f )
  210. rot xor \ a c b^d
  211. -rot xor \ b^d a^c
  212. swap
  213. ;
  214. : dand rot and -rot and swap ;
  215. : dor rot or -rot or swap ;
  216. : dinvert invert swap invert swap ;
  217. : d< \ ( al ah bl bh -- flag )
  218. rot \ al bl bh ah
  219. 2dup =
  220. if
  221. 2drop u<
  222. else
  223. 2nip >
  224. then
  225. ;
  226. : d> 2swap d< ;
  227. : d0<= d# 0. ;fallthru
  228. : d<= d> invert ;
  229. : d>= d< invert ;
  230. : d0= or 0= ;
  231. : d0< d# 0. d< ;
  232. : d0<> d0= invert ;
  233. : d<> d= invert ;
  234. : d2* 2dup d+ ;
  235. : d2/ dup d# 15 lshift >r 2/ swap 2/ r> or swap ;
  236. : dmax 2over 2over d< if 2swap then 2drop ;
  237. : d1- d# -1. d+ ;
  238. : d+! ( v. addr -- )
  239. dup >r
  240. 2@
  241. d+
  242. r>
  243. 2!
  244. ;
  245. : move ( addr1 addr2 u -- )
  246. d# 0 do
  247. over @ over !
  248. 2+ swap 2+ swap
  249. loop
  250. 2drop
  251. ;
  252. : cmove ( c-addr1 c-addr2 u -- )
  253. d# 0 do
  254. over c@ over c!
  255. 1+ swap 1+ swap
  256. loop
  257. 2drop
  258. ;
  259. : bounds ( a n -- a+n a ) OVER + SWAP ;
  260. : fill ( c-addr u char -- ) ( 6.1.1540 )
  261. >R bounds
  262. BEGIN 2dupxor
  263. WHILE R@ OVER C! 1+
  264. REPEAT R> DROP 2DROP ;
  265. \ Math
  266. 1 [IF]
  267. create scratch d# 2 allot
  268. : um* ( u1 u2 -- ud )
  269. scratch !
  270. d# 0.
  271. d# 16 0do
  272. 2dup d+
  273. rot dup 0< if
  274. 2* -rot
  275. scratch @ d# 0 d+
  276. else
  277. 2* -rot
  278. then
  279. loop
  280. rot drop
  281. ;
  282. [ELSE]
  283. : um* mult_a ! mult_b ! mult_p 2@ ;
  284. [THEN]
  285. : * um* drop ;
  286. : abssgn ( a b -- |a| |b| negf )
  287. 2dup xor 0< >r abs swap abs swap r> ;
  288. : m* abssgn >r um* r> if dnegate then ;
  289. : divstep
  290. ( divisor dq hi )
  291. 2*
  292. over 0< if 1+ then
  293. swap 2* swap
  294. rot ( dq hi divisor )
  295. 2dup >= if
  296. tuck ( dq divisor hi divisor )
  297. -
  298. swap ( dq hi divisor )
  299. rot 1+ ( hi divisor dq )
  300. rot ( divisor dq hi )
  301. else
  302. -rot
  303. then
  304. ;
  305. : um/mod ( ud u1 -- u2 u3 ) ( 6.1.2370 )
  306. -rot
  307. divstep divstep divstep divstep
  308. divstep divstep divstep divstep
  309. divstep divstep divstep divstep
  310. divstep divstep divstep divstep
  311. rot drop swap
  312. ;
  313. : /mod >R S>D R> ;fallthru
  314. : SM/REM ( d n -- r q ) ( 6.1.2214 ) ( symmetric )
  315. OVER >R >R DABS R@ ABS UM/MOD
  316. R> R@ XOR 0< IF NEGATE THEN R> 0< IF >R NEGATE R> THEN ;
  317. : / /mod nip ;
  318. : mod /mod drop ;
  319. : */mod >R M* R> SM/REM ;
  320. : */ */mod nip ;
  321. : t2* over >r >r d2*
  322. r> 2* r> 0< d# 1 and + ;
  323. variable divisor
  324. : m*/mod
  325. divisor !
  326. tuck um* 2swap um* ( hi. lo. )
  327. ( m0 h l m1 )
  328. swap >r d# 0 d+ r> ( m h l )
  329. -rot ( l m h )
  330. d# 32 0do
  331. t2*
  332. dup divisor @ >= if
  333. divisor @ -
  334. rot 1+ -rot
  335. then
  336. loop
  337. ;
  338. : m*/ m*/mod drop ;
  339. \ Numeric output - from eforth
  340. variable base
  341. variable hld
  342. create pad 84 allot create pad|
  343. : <# ( -- ) ( 6.1.0490 )( h# 96 ) pad| HLD ! ;
  344. : DIGIT ( u -- c ) d# 9 OVER < d# 7 AND + [CHAR] 0 + ;
  345. : HOLD ( c -- ) ( 6.1.1670 ) HLD @ 1- DUP HLD ! C! ;
  346. : # ( d -- d ) ( 6.1.0030 )
  347. d# 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP DIGIT HOLD R> ;
  348. : #S ( d -- d ) ( 6.1.0050 ) BEGIN # 2DUP OR 0= UNTIL ;
  349. : #> ( d -- a u ) ( 6.1.0040 ) 2DROP HLD @ pad| OVER - ;
  350. : SIGN ( n -- ) ( 6.1.2210 ) 0< IF [CHAR] - HOLD THEN ;
  351. \ hex(int((1<<24) * (115200 / 2400.) / (WB_CLOCK_FREQ / 2400.)))
  352. \ d# 42000000 constant WB_CLOCK_FREQ
  353. [ 48000000 17 12 */ ] constant WB_CLOCK_FREQ
  354. 0 [IF]
  355. : uartbase
  356. [ $100000000. 115200 WB_CLOCK_FREQ m*/ drop $ffffff00 and dup swap 16 rshift ] 2literal
  357. ;
  358. : emit-uart
  359. begin uart_0 @ 0= until
  360. s>d
  361. uartbase dor
  362. uart_1 ! uart_0 !
  363. ;
  364. [ELSE]
  365. : emit-uart drop ;
  366. [THEN]
  367. create 'emit
  368. meta emit-uart t, target
  369. : emit 'emit @ execute ;
  370. : cr d# 13 emit d# 10 emit ;
  371. d# 32 constant bl
  372. : space bl emit ;
  373. : spaces begin dup 0> while space 1- repeat drop ;
  374. : hex1 d# 15 and dup d# 10 < if d# 48 else d# 55 then + emit ;
  375. : hex2
  376. dup
  377. d# 4 rshift
  378. hex1 hex1
  379. ;
  380. : hex4
  381. dup
  382. d# 8 rshift
  383. hex2 hex2 ;
  384. : hex8 hex4 hex4 ;
  385. : type
  386. d# 0 do
  387. dup c@ emit
  388. 1+
  389. loop
  390. drop
  391. ;
  392. : dump
  393. ( addr u )
  394. 0do
  395. dup d# 15 and 0= if dup cr hex4 [char] : emit space space then
  396. dup c@ hex2 space 1+
  397. loop
  398. cr drop
  399. ;
  400. : dump16
  401. ( addr u )
  402. 0do
  403. dup hex4 [char] : emit space dup @ hex4 cr 2+
  404. loop
  405. drop
  406. ;
  407. : decimal d# 10 base ! ;
  408. : hex d# 16 base ! ;
  409. : S.R ( a u n -- ) OVER - SPACES TYPE ;
  410. : D.R ( d n -- ) ( 8.6.1.1070 ) >R DUP >R DABS <# #S R> SIGN #> R> S.R ;
  411. : U.R ( u n -- ) ( 6.2.2330 ) d# 0 SWAP D.R ;
  412. : .R ( n n -- ) ( 6.2.0210 ) >R S>D R> D.R ;
  413. : D. ( d -- ) ( 8.6.1.1060 ) d# 0 D.R SPACE ;
  414. : U. ( u -- ) ( 6.1.2320 ) d# 0 D. ;
  415. : . ( n -- ) ( 6.1.0180 ) BASE @ d# 10 XOR IF U. EXIT THEN S>D D. ;
  416. : ? ( a -- ) ( 15.6.1.0600 ) @ . ;
  417. ( Numeric input )
  418. : DIGIT? ( c base -- u f ) ( 0xA3 )
  419. >R [CHAR] 0 - D# 9 OVER <
  420. IF D# 7 - DUP D# 10 < OR THEN DUP R> U< ;
  421. : >number ( ud a u -- ud a u ) ( 6.1.0570 )
  422. begin
  423. dup 0= if exit then
  424. over c@ base @ digit? if
  425. >r 2swap
  426. drop base @ um*
  427. r> s>d d+ 2swap
  428. d# 1 /string >number
  429. else
  430. drop exit
  431. then
  432. again
  433. ;
  434. : .s
  435. [char] < emit
  436. depth dup hex2
  437. [char] > emit
  438. d# 8 min
  439. ?dup if
  440. 0do
  441. i pick hex4 space
  442. loop
  443. then
  444. ;
  445. build-debug? [IF]
  446. : (assert)
  447. s" **** ASSERTION FAILED **** " type
  448. ;fallthru
  449. : (snap)
  450. type space
  451. s" LINE " type
  452. .
  453. [char] : emit
  454. space
  455. .s
  456. cr
  457. ;
  458. [THEN]
  459. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  460. : endian dup d# 8 lshift swap d# 8 rshift or ;
  461. : 2endian endian swap endian ;
  462. : swab endian ;
  463. : typepad ( c-addr u w ) over - >r type r> spaces ;
  464. : even? d# 1 and 0= ;
  465. \ rise? and fall? act like ! - except that they leave a true
  466. \ if the value rose or fell, respectively.
  467. : rise? ( u a -- f ) 2dup @ u> >r ! r> ;
  468. : fall? ( u a -- f ) 2dup @ u< >r ! r> ;
  469. ]module