eforth.fs 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729
  1. meta
  2. 0 value _next
  3. variable _lit
  4. variable _invert
  5. variable _equal
  6. variable _plus
  7. variable _mul
  8. variable _rshift
  9. variable _and
  10. variable _or
  11. variable _xor
  12. variable _<
  13. variable _u<
  14. variable _dup
  15. variable _drop
  16. variable _swap
  17. variable _over
  18. variable _c!
  19. variable _!
  20. variable _c@
  21. variable _@
  22. variable _>r
  23. variable _r>
  24. variable _r@
  25. variable _branch
  26. variable _0branch
  27. variable _doconst
  28. variable _dovar
  29. variable _docol
  30. variable _semis
  31. target
  32. start-microcode eforth
  33. \ Interface:
  34. \ COMM+0 instruction pointer
  35. COMM+0 constant IP
  36. : 1+ d# 1 + ;
  37. : @ dup c@ swap 1+ c@ swab or ;
  38. : IP!
  39. IP ;fallthru
  40. : ! over swab over 1+ c! c! ;
  41. : IP@
  42. \ COMM+0 c@ COMM+1 c@ swab or ;
  43. IP @ ;
  44. : fetch \ fetch cell from IP, then increment IP
  45. IP@ dup d# 2 + IP! @ ;
  46. meta there _lit ! target
  47. t: _lit
  48. drop
  49. fetch
  50. ;fallthru
  51. meta there to _next target
  52. : _next
  53. fetch \ fetch xt
  54. dup 1+ swap \ stack the args pointer
  55. c@ >r ; \ jump to the code addr
  56. meta
  57. : def there wordstr evaluate ! t: ;
  58. : term _next ubranch t;fallthru ;
  59. target
  60. def _doconst
  61. @ ;fallthru
  62. def _dovar
  63. term
  64. def _invert drop invert term
  65. def _equal drop = term
  66. def _plus drop + term
  67. def _mul drop * term
  68. def _rshift drop rshift term
  69. def _and drop and term
  70. def _or drop or term
  71. def _xor drop xor term
  72. def _< drop < term
  73. def _u< drop u< term
  74. def _dup drop dup term
  75. def _drop drop drop term
  76. def _swap drop swap term
  77. def _over drop over term
  78. def _c! drop c! term
  79. def _! drop ! term
  80. def _c@ drop c@ term
  81. def _@ drop @ term
  82. def _>r drop >r term
  83. def _r> drop r> term
  84. def _r@ drop r@ term
  85. def _branch drop fetch IP! term
  86. def _0branch drop fetch swap if drop else IP! then term
  87. \ start a colon definition: push IP and use args as new IP
  88. def _docol
  89. IP@ >r ;fallthru
  90. : IP!term
  91. IP! term
  92. \ end a colon definition: pop IP
  93. def _semis
  94. drop r> IP!term ;
  95. [ _next ] constant main
  96. end-microcode
  97. meta 0 to outfile
  98. only forth
  99. also metacompiler
  100. also forth definitions also
  101. cr cr cr
  102. 4000 value dst
  103. create dstmem 8000 allot
  104. s" dump.eforth" w/o create-file throw value dump.eforth
  105. : dstc@
  106. dstmem + c@ ;
  107. : dstc!
  108. dstmem + c! ;
  109. : dst!
  110. over 8 rshift over 1+ dstc! dstc! ;
  111. : c>>
  112. dst dstc!
  113. dst 1+ to dst ;
  114. : >>
  115. dst dst!
  116. dst 2 + to dst ;
  117. : s>> ( addr u -- )
  118. 0 do dup c@ c>> 1+ loop drop ;
  119. 0 value 'link
  120. \ These definitions go into the gdforth wordlist
  121. vocabulary gdforth
  122. : gdf-define
  123. only
  124. gdforth definitions
  125. also metacompiler
  126. also forth
  127. ;
  128. : gdf-use
  129. only
  130. gdforth definitions
  131. ;
  132. gdf-define
  133. 0 value >link
  134. : dumpmem
  135. \ bring vocab pointer up to date
  136. dst 2 - >link .s dst!
  137. dstmem 4000 + dst 4000 - dump.eforth write-file throw
  138. ;
  139. : meta meta ;
  140. \ name
  141. \ length
  142. \ prev
  143. \ cfa <--- xt
  144. \ args
  145. : label
  146. wordstr tuck s>> c>>
  147. 'link >> dst to 'link
  148. create dst ,
  149. does> @ >> ;
  150. label gdbranch _branch @ c>>
  151. label gd0branch _0branch @ c>>
  152. : begin dst ;
  153. : again gdbranch >> ;
  154. : until gd0branch >> ;
  155. : if gd0branch dst 7777 >> ;
  156. : else gdbranch dst >r 8888 >> dst swap dst! r> ;
  157. : then dst swap dst! ;
  158. : while gd0branch dst 7777 >> ;
  159. : repeat swap gdbranch >> dst swap dst! ;
  160. label (lit) _lit @ c>>
  161. label invert _invert @ c>>
  162. label = _equal @ c>>
  163. label + _plus @ c>>
  164. label * _mul @ c>>
  165. label rshift _rshift @ c>>
  166. label and _and @ c>>
  167. label or _or @ c>>
  168. label xor _xor @ c>>
  169. label < _< @ c>>
  170. label u< _u< @ c>>
  171. label c! _c! @ c>>
  172. label ! _! @ c>>
  173. label c@ _c@ @ c>>
  174. label @ _@ @ c>>
  175. label >r _>r @ c>>
  176. label r> _r> @ c>>
  177. label r@ _r@ @ c>>
  178. label dup _dup @ c>>
  179. label drop _drop @ c>>
  180. label swap _swap @ c>>
  181. label over _over @ c>>
  182. label semis _semis @ c>>
  183. : create label ;
  184. : constant label _doconst @ c>> >> ;
  185. : variable label _dovar @ c>> 0 >> ;
  186. : ivariable label _dovar @ c>> >> ; \ initialized variable
  187. : the-link label _dovar @ c>> dst .s to >link 'link >> ; \ variable init to 'link
  188. : allot dst +! ;
  189. : bc-var (lit) _dovar @ >> ;
  190. : bc-col (lit) _docol @ >> ;
  191. : bc-const (lit) _doconst @ >> ;
  192. : bc-var# _dovar @ 0ff and ;
  193. : bc-col# _docol @ 0ff and ;
  194. : bc-const# _doconst @ 0ff and ;
  195. : semis# ['] semis >body @ ;
  196. : literal# ['] (lit) >body @ ;
  197. : branch# ['] gdbranch >body @ ;
  198. : 0branch# ['] gd0branch >body @ ;
  199. : '(lit) (lit) (lit) ;
  200. : \ ['] \ execute ;
  201. : ( ['] ( execute ;
  202. : : label _docol @ c>> ;
  203. : ; semis ;
  204. : x; semis ; \ alternative name for when ; gets overloaded
  205. : immediate
  206. 'link 3 - dup dstc@ 80 or swap dstc! ;
  207. : h# (lit) h# >> ;
  208. : d# (lit) d# >> ;
  209. : [char] (lit) char >> ;
  210. : fwd4 (lit) dst 4 + >> ;
  211. gdf-use
  212. \ constants used for making code
  213. semis# constant semis# \ address of the semis word
  214. literal# constant literal# \ address of the literal word
  215. branch# constant branch# \ address of the branch word
  216. 0branch# constant 0branch# \ address of the 0branch word
  217. bc-var# constant bc-var# \ the code byte for _dovar
  218. bc-col# constant bc-col# \ the code byte for _docol
  219. bc-const# constant bc-const# \ code byte for _doconst
  220. : 1+ d# 1 + ;
  221. : 1- d# -1 + ;
  222. : <> = invert ;
  223. : 2dup over over ;
  224. : 0< d# 0 < ;
  225. : tuck swap over ;
  226. 20 constant BL
  227. 0 constant FALSE
  228. -1 constant TRUE
  229. 10 ivariable BASE
  230. : HEX ( -- )( 6.2.1660 ) D# 16 BASE ! ;
  231. : DECIMAL ( -- )( 6.1.1170 ) D# 10 BASE ! ;
  232. : NIP ( n1 n2 -- n2 )( 6.2.1930 ( 0x4D ) SWAP DROP ;
  233. : ROT ( n1 n2 n3 -- n2 n3 n1 )( 6.1.2160 ( 0x4A ) >R SWAP R> SWAP ;
  234. : 2DROP ( n n -- )( 6.1.0370 ( 0x52 ) DROP DROP ;
  235. : 2DUP ( n1 n2 -- n1 n2 n1 n2 )( 6.1.0380 ( 0x53 ) OVER OVER ;
  236. : ?DUP ( n -- n n | 0 )( 6.1.0630 ( 0x50 ) DUP IF DUP THEN ;
  237. : INVERT ( n -- n )( 6.1.1720 ( 0x26 ) D# -1 XOR ;
  238. : NEGATE ( n -- n )( 6.1.1910 ( 0x2C ) INVERT D# 1 + ;
  239. : - ( n n -- n )( 6.1.0160 ( 0x1F ) NEGATE + ;
  240. : ABS ( n -- u )( 6.1.0690 ( 0x2D ) DUP 0< IF NEGATE THEN ;
  241. : 0= ( n -- f )( 6.1.0270 ( 0x34 ) D# 0 = ;
  242. : MIN ( n n -- n )( 6.1.1880 ( 0x2E ) 2DUP < IF BEGIN DROP ;
  243. : MAX ( n n -- n )( 6.1.1870 ( 0x2F ) 2DUP < UNTIL THEN NIP ;
  244. : WITHIN ( u ul uh -- f )( 6.2.2440 ( 0x45 ) OVER - >R - R> U< ;
  245. : 0<> ( n -- f ) d# 0 = invert ;
  246. : UPPER ( c -- C ) \ convert to uppercase ( upc ( 0x81 ) \ bbb
  247. \ DUP [CHAR] a h# 7B WITHIN IF BL XOR THEN ;
  248. h# 60 over < if h# 5f and then ;
  249. \ -----------------------------------------------------------
  250. 2000 constant RAM_PAL
  251. 0 constant tib
  252. variable >in \ offset into TIB
  253. variable tibsz \ how much space remains
  254. 2892 constant dp
  255. 2895 constant BLKRDY
  256. 2896 constant COUT
  257. 2897 constant COUTRDY
  258. 2898 constant CIN
  259. : ser-emit
  260. COUT c!
  261. d# 1 COUTRDY c!
  262. begin
  263. COUTRDY c@ 0=
  264. until
  265. ;
  266. 400 ivariable cursor
  267. : vid-emit
  268. dup d# 10 = if
  269. drop cursor @ h# ffc0 and cursor !
  270. else
  271. dup d# 13 = if
  272. drop cursor @ h# 40 + cursor !
  273. else
  274. cursor @ tuck c! 1+ cursor !
  275. then
  276. then
  277. ;
  278. : page
  279. d# 4096 d# 0 begin
  280. d# 0 over c!
  281. 1+ 2dup =
  282. until 2drop
  283. h# 400 cursor !
  284. ;
  285. : emit vid-emit ;
  286. : space bl emit ;
  287. : cr d# 13 emit d# 10 emit ;
  288. : hex1 d# 15 and dup d# 10 < if d# 48 else d# 55 then + emit ;
  289. : hex2
  290. dup
  291. d# 4 rshift
  292. hex1 hex1
  293. ;
  294. : hex4
  295. dup
  296. d# 8 rshift
  297. hex2 hex2 ;
  298. : hex8 hex4 hex4 ;
  299. : . hex4 space ;
  300. : snap
  301. [char] S emit
  302. [char] N emit
  303. [char] A emit
  304. [char] P emit
  305. cr
  306. hex4 cr
  307. hex4 cr
  308. hex4 cr
  309. hex4 cr
  310. hex4 cr
  311. hex4 cr
  312. hex4 cr
  313. hex4 cr
  314. begin again
  315. ;
  316. : CHAR+ 1+ ;
  317. : CHARS ;
  318. : PAUSE ;
  319. : +! ( n a -- )( 6.1.0130 ( 0x6C ) DUP >R @ + R> ! ;
  320. : COUNT ( a -- a c )( 6.1.0980 ( 0x84 ) DUP CHAR+ SWAP C@ ;
  321. : BOUNDS ( a u -- a+u a )( 0xAC ) OVER + SWAP ;
  322. : /STRING ( ca u n -- ca+n u-n )( 17.6.1.0245 ) SWAP OVER - >R CHARS + R> ;
  323. : TYPE ( ca u -- )( 6.1.2310 ( 0x90 )
  324. PAUSE CHARS BOUNDS BEGIN 2DUP XOR WHILE COUNT EMIT REPEAT 2DROP ;
  325. : SAME? ( ca ca u -- f )
  326. begin
  327. dup
  328. while
  329. >r
  330. over c@ upper over c@ upper <> if
  331. r> drop 2drop false ;
  332. then
  333. 1+ swap 1+ swap
  334. r> 1-
  335. repeat
  336. drop 2drop true ;
  337. : isimmediate ( xt -- f )
  338. d# -3 + c@ h# 80 and 0<> ;
  339. : name? ( xt -- ca u )
  340. d# -3 + dup c@ h# 7f and tuck - swap ;
  341. : sayword ( xt -- )
  342. name? type ;
  343. : inch
  344. >in @ tib + ;
  345. : inch+1
  346. d# 1 >in +! ;
  347. : execute
  348. fwd4 !
  349. + ;
  350. : advance
  351. d# 1 /string d# 1 >in +! ;
  352. : skipbl ( ca u -- ca u ) \ skip blank chars
  353. begin
  354. over c@ bl = over 0<> and
  355. while
  356. advance
  357. repeat
  358. ;
  359. : skipnbl ( ca u -- ca u ) \ skip nonblank chars
  360. begin
  361. over c@ bl <> over 0<> and
  362. while
  363. advance
  364. repeat
  365. ;
  366. variable source/a
  367. variable source/l
  368. : source ( -- ca u )( 6.1.2216 )
  369. source/a @ source/l @ ;
  370. : source>in
  371. source >in @ /string ;
  372. : parse-word ( -- ca u )
  373. source>in
  374. skipbl
  375. over >r
  376. skipnbl
  377. drop
  378. r> tuck -
  379. ;
  380. \ name
  381. \ length
  382. \ prev
  383. \ cfa <--- xt
  384. \ args
  385. : here dp @ ;
  386. : c, here c! d# 1 dp +! ;
  387. : , here ! d# 2 dp +! ;
  388. : s, begin dup while over c@ c, d# 1 /string repeat 2drop ;
  389. the-link voc
  390. 0 ivariable state
  391. : head, ( "name" -- )
  392. parse-word
  393. tuck s, c,
  394. voc @ , here voc !
  395. ;
  396. : digit ( c -- u )
  397. upper [CHAR] 0 - D# 9 OVER <
  398. IF D# 7 - DUP D# 10 < OR THEN ;
  399. : 1/string d# 1 /string ;
  400. : isnumber ( ca u -- f )
  401. \ over c@ [char] - = if 1/string then
  402. true >r
  403. begin
  404. dup
  405. while
  406. over c@ digit base @ u< r> and >r
  407. 1/string
  408. repeat
  409. 2drop r>
  410. ;
  411. : asnumber ( ca u -- false | n true )
  412. d# 0 >r
  413. begin
  414. dup
  415. while
  416. over c@ digit
  417. r> base @ * + >r
  418. 1/string
  419. repeat
  420. 2drop r> true
  421. ;
  422. : words
  423. voc @
  424. begin
  425. dup
  426. while
  427. dup sayword space
  428. d# -2 + @
  429. repeat
  430. cr
  431. ;
  432. : sfind ( ca u -- xt | ca u 0 )
  433. >r
  434. voc @
  435. begin
  436. dup
  437. while
  438. 2dup name? ( ca xt ca ca u )
  439. dup r@ = if
  440. SAME? if r> drop nip ; then
  441. else
  442. 2drop drop
  443. then
  444. d# -2 + @
  445. repeat
  446. drop r> false
  447. ;
  448. variable (quit)
  449. : interpret
  450. begin
  451. parse-word
  452. dup
  453. while
  454. sfind ?dup if
  455. dup isimmediate state @ 0= or if
  456. execute
  457. else
  458. ,
  459. then
  460. else
  461. 2dup isnumber if
  462. state @ if
  463. '(lit) ,
  464. asnumber drop
  465. ,
  466. else
  467. asnumber drop
  468. then
  469. else
  470. [char] ? emit type (quit) @ execute
  471. then
  472. then
  473. repeat
  474. 2drop
  475. ;
  476. ( Gameduino system constants JCB 16:45 04/15/11)
  477. 0000 constant RAM_PIC 1000 constant RAM_CHR
  478. 2000 constant RAM_PAL 2800 constant IDENT
  479. 2801 constant REV 2802 constant FRAME
  480. 2803 constant VBLANK 2804 constant SCROLL_X
  481. 2806 constant SCROLL_Y 2808 constant JK_MODE
  482. 280a constant SPR_DISABLE 280b constant SPR_PAGE
  483. 280c constant IOMODE 280e constant BG_COLOR
  484. 2810 constant SAMPLE_L 2812 constant SAMPLE_R
  485. 2a00 constant VOICES 2840 constant PALETTE16A
  486. 2860 constant PALETTE16B 2880 constant PALETTE4A
  487. 2888 constant PALETTE4B 2890 constant COMM
  488. 2900 constant COLLISION 2c00 constant J1_CODE
  489. 3000 constant RAM_SPR 3800 constant RAM_SPRPAL
  490. 4000 constant RAM_SPRIMG
  491. \ screen \ 11
  492. 8016 constant FLASH_MISO
  493. 8018 constant FLASH_MOSI
  494. 801a constant FLASH_SCK
  495. 801c constant FLASH_SSEL
  496. ( SPI JCB 16:42 04/15/11)
  497. : off d# 0 swap c! ; : on d# 1 swap c! ;
  498. : spi-sel FLASH_SSEL off ;
  499. : spi-unsel FLASH_SSEL on ;
  500. : spi-cold spi-unsel FLASH_SCK off ;
  501. : spi-1bit ( u -- u ) \ single bit via SPI
  502. d# 2 *
  503. dup d# 8 rshift FLASH_MOSI c! \ write MSB to MOSI
  504. FLASH_SCK on \ raise clock
  505. FLASH_MISO c@ or \ read MISO into LSB
  506. FLASH_SCK off ; \ drop clock
  507. : spi-xfer ( u -- u )
  508. spi-1bit spi-1bit spi-1bit spi-1bit
  509. spi-1bit spi-1bit spi-1bit spi-1bit ;
  510. : >spi spi-xfer drop ;
  511. ( Atmel flash JCB 07:32 04/16/11)
  512. \ http://www.atmel.com/dyn/resources/prod_documents/doc3638.pdf
  513. : flash-status spi-sel h# D7 spi-xfer spi-xfer spi-unsel ;
  514. : flash-ready? begin flash-status h# 80 and until ;
  515. : flash-page ( u -- ) \ 512*(572+u)
  516. d# 572 +
  517. dup d# 7 rshift >spi
  518. d# 2 * >spi
  519. d# 0 >spi ;
  520. : page>flash ( a u -- a' u' )
  521. spi-sel
  522. h# 82 >spi tuck flash-page
  523. d# 264 bounds begin
  524. dup c@ >spi
  525. 1+ 2dup =
  526. until drop swap 1+ spi-unsel
  527. flash-ready? ;
  528. : blk>flash ( a u -- )
  529. d# 4 * page>flash page>flash page>flash page>flash 2drop ;
  530. : flash>page ( u -- )
  531. spi-sel
  532. h# 03 >spi
  533. flash-page
  534. h# 0 h# 400 bounds begin
  535. d# 0 spi-xfer over c!
  536. 1+ 2dup =
  537. until 2drop spi-unsel ;
  538. : interpret0
  539. d# 0
  540. begin
  541. >r d# 0 >in !
  542. r@ source/a ! d# 64 source/l ! interpret
  543. r> h# 40 +
  544. dup h# 400 =
  545. until drop
  546. ;
  547. : load
  548. d# 4 * flash>page
  549. \ d# 1024 d# 0 begin dup c@ emit 1+ 2dup = until
  550. interpret0
  551. ;
  552. variable blk
  553. : key
  554. begin CIN c@ ?dup until
  555. d# 0 CIN c! ;
  556. : . hex4 ;
  557. : quit
  558. begin
  559. cr
  560. begin
  561. d# 127 emit d# -1 cursor +!
  562. key dup d# 13 xor
  563. while
  564. emit
  565. repeat
  566. drop
  567. cursor @ h# ffc0 and
  568. cursor @ h# 003f and
  569. space
  570. d# 0 >in !
  571. source/l ! source/a ! interpret
  572. space
  573. [char] o emit
  574. [char] k emit
  575. again
  576. ;
  577. : (
  578. source>in
  579. begin
  580. over c@ [char] ) <>
  581. while
  582. advance
  583. repeat advance 2drop ;
  584. : nucok
  585. [char] N emit
  586. [char] U emit
  587. [char] C emit
  588. space
  589. [char] O emit
  590. [char] K emit
  591. cr ;
  592. \ : sec
  593. \ spi-sel 77 spi-xfer spi-xfer spi-xfer spi-xfer drop
  594. \ 80 begin 0 spi-xfer hex2 space next cr ;
  595. : f;
  596. semis# ,
  597. d# 0 state ! ; immediate
  598. : :
  599. head,
  600. bc-col c,
  601. d# 1 state !
  602. ;
  603. label main
  604. nucok
  605. [char] J IOMODE c! spi-cold
  606. d# 0 blk !
  607. begin
  608. begin BLKRDY c@ until
  609. \ d# 0 blk @ blk>flash d# 1 blk +!
  610. interpret0
  611. d# 0 BLKRDY c!
  612. again
  613. label blkmain
  614. nucok
  615. [char] J IOMODE c! spi-cold
  616. d# 0 begin
  617. dup >r load r> 1+
  618. again
  619. label stump
  620. main
  621. dumpmem
  622. meta