meta 0 value _next variable _lit variable _invert variable _equal variable _plus variable _mul variable _rshift variable _and variable _or variable _xor variable _< variable _u< variable _dup variable _drop variable _swap variable _over variable _c! variable _! variable _c@ variable _@ variable _>r variable _r> variable _r@ variable _branch variable _0branch variable _doconst variable _dovar variable _docol variable _semis target start-microcode eforth \ Interface: \ COMM+0 instruction pointer COMM+0 constant IP : 1+ d# 1 + ; : @ dup c@ swap 1+ c@ swab or ; : IP! IP ;fallthru : ! over swab over 1+ c! c! ; : IP@ \ COMM+0 c@ COMM+1 c@ swab or ; IP @ ; : fetch \ fetch cell from IP, then increment IP IP@ dup d# 2 + IP! @ ; meta there _lit ! target t: _lit drop fetch ;fallthru meta there to _next target : _next fetch \ fetch xt dup 1+ swap \ stack the args pointer c@ >r ; \ jump to the code addr meta : def there wordstr evaluate ! t: ; : term _next ubranch t;fallthru ; target def _doconst @ ;fallthru def _dovar term def _invert drop invert term def _equal drop = term def _plus drop + term def _mul drop * term def _rshift drop rshift term def _and drop and term def _or drop or term def _xor drop xor term def _< drop < term def _u< drop u< term def _dup drop dup term def _drop drop drop term def _swap drop swap term def _over drop over term def _c! drop c! term def _! drop ! term def _c@ drop c@ term def _@ drop @ term def _>r drop >r term def _r> drop r> term def _r@ drop r@ term def _branch drop fetch IP! term def _0branch drop fetch swap if drop else IP! then term \ start a colon definition: push IP and use args as new IP def _docol IP@ >r ;fallthru : IP!term IP! term \ end a colon definition: pop IP def _semis drop r> IP!term ; [ _next ] constant main end-microcode meta 0 to outfile only forth also metacompiler also forth definitions also cr cr cr 4000 value dst create dstmem 8000 allot s" dump.eforth" w/o create-file throw value dump.eforth : dstc@ dstmem + c@ ; : dstc! dstmem + c! ; : dst! over 8 rshift over 1+ dstc! dstc! ; : c>> dst dstc! dst 1+ to dst ; : >> dst dst! dst 2 + to dst ; : s>> ( addr u -- ) 0 do dup c@ c>> 1+ loop drop ; 0 value 'link \ These definitions go into the gdforth wordlist vocabulary gdforth : gdf-define only gdforth definitions also metacompiler also forth ; : gdf-use only gdforth definitions ; gdf-define 0 value >link : dumpmem \ bring vocab pointer up to date dst 2 - >link .s dst! dstmem 4000 + dst 4000 - dump.eforth write-file throw ; : meta meta ; \ name \ length \ prev \ cfa <--- xt \ args : label wordstr tuck s>> c>> 'link >> dst to 'link create dst , does> @ >> ; label gdbranch _branch @ c>> label gd0branch _0branch @ c>> : begin dst ; : again gdbranch >> ; : until gd0branch >> ; : if gd0branch dst 7777 >> ; : else gdbranch dst >r 8888 >> dst swap dst! r> ; : then dst swap dst! ; : while gd0branch dst 7777 >> ; : repeat swap gdbranch >> dst swap dst! ; label (lit) _lit @ c>> label invert _invert @ c>> label = _equal @ c>> label + _plus @ c>> label * _mul @ c>> label rshift _rshift @ c>> label and _and @ c>> label or _or @ c>> label xor _xor @ c>> label < _< @ c>> label u< _u< @ c>> label c! _c! @ c>> label ! _! @ c>> label c@ _c@ @ c>> label @ _@ @ c>> label >r _>r @ c>> label r> _r> @ c>> label r@ _r@ @ c>> label dup _dup @ c>> label drop _drop @ c>> label swap _swap @ c>> label over _over @ c>> label semis _semis @ c>> : create label ; : constant label _doconst @ c>> >> ; : variable label _dovar @ c>> 0 >> ; : ivariable label _dovar @ c>> >> ; \ initialized variable : the-link label _dovar @ c>> dst .s to >link 'link >> ; \ variable init to 'link : allot dst +! ; : bc-var (lit) _dovar @ >> ; : bc-col (lit) _docol @ >> ; : bc-const (lit) _doconst @ >> ; : bc-var# _dovar @ 0ff and ; : bc-col# _docol @ 0ff and ; : bc-const# _doconst @ 0ff and ; : semis# ['] semis >body @ ; : literal# ['] (lit) >body @ ; : branch# ['] gdbranch >body @ ; : 0branch# ['] gd0branch >body @ ; : '(lit) (lit) (lit) ; : \ ['] \ execute ; : ( ['] ( execute ; : : label _docol @ c>> ; : ; semis ; : x; semis ; \ alternative name for when ; gets overloaded : immediate 'link 3 - dup dstc@ 80 or swap dstc! ; : h# (lit) h# >> ; : d# (lit) d# >> ; : [char] (lit) char >> ; : fwd4 (lit) dst 4 + >> ; gdf-use \ constants used for making code semis# constant semis# \ address of the semis word literal# constant literal# \ address of the literal word branch# constant branch# \ address of the branch word 0branch# constant 0branch# \ address of the 0branch word bc-var# constant bc-var# \ the code byte for _dovar bc-col# constant bc-col# \ the code byte for _docol bc-const# constant bc-const# \ code byte for _doconst : 1+ d# 1 + ; : 1- d# -1 + ; : <> = invert ; : 2dup over over ; : 0< d# 0 < ; : tuck swap over ; 20 constant BL 0 constant FALSE -1 constant TRUE 10 ivariable BASE : HEX ( -- )( 6.2.1660 ) D# 16 BASE ! ; : DECIMAL ( -- )( 6.1.1170 ) D# 10 BASE ! ; : NIP ( n1 n2 -- n2 )( 6.2.1930 ( 0x4D ) SWAP DROP ; : ROT ( n1 n2 n3 -- n2 n3 n1 )( 6.1.2160 ( 0x4A ) >R SWAP R> SWAP ; : 2DROP ( n n -- )( 6.1.0370 ( 0x52 ) DROP DROP ; : 2DUP ( n1 n2 -- n1 n2 n1 n2 )( 6.1.0380 ( 0x53 ) OVER OVER ; : ?DUP ( n -- n n | 0 )( 6.1.0630 ( 0x50 ) DUP IF DUP THEN ; : INVERT ( n -- n )( 6.1.1720 ( 0x26 ) D# -1 XOR ; : NEGATE ( n -- n )( 6.1.1910 ( 0x2C ) INVERT D# 1 + ; : - ( n n -- n )( 6.1.0160 ( 0x1F ) NEGATE + ; : ABS ( n -- u )( 6.1.0690 ( 0x2D ) DUP 0< IF NEGATE THEN ; : 0= ( n -- f )( 6.1.0270 ( 0x34 ) D# 0 = ; : MIN ( n n -- n )( 6.1.1880 ( 0x2E ) 2DUP < IF BEGIN DROP ; : MAX ( n n -- n )( 6.1.1870 ( 0x2F ) 2DUP < UNTIL THEN NIP ; : WITHIN ( u ul uh -- f )( 6.2.2440 ( 0x45 ) OVER - >R - R> U< ; : 0<> ( n -- f ) d# 0 = invert ; : UPPER ( c -- C ) \ convert to uppercase ( upc ( 0x81 ) \ bbb \ DUP [CHAR] a h# 7B WITHIN IF BL XOR THEN ; h# 60 over < if h# 5f and then ; \ ----------------------------------------------------------- 2000 constant RAM_PAL 0 constant tib variable >in \ offset into TIB variable tibsz \ how much space remains 2892 constant dp 2895 constant BLKRDY 2896 constant COUT 2897 constant COUTRDY 2898 constant CIN : ser-emit COUT c! d# 1 COUTRDY c! begin COUTRDY c@ 0= until ; 400 ivariable cursor : vid-emit dup d# 10 = if drop cursor @ h# ffc0 and cursor ! else dup d# 13 = if drop cursor @ h# 40 + cursor ! else cursor @ tuck c! 1+ cursor ! then then ; : page d# 4096 d# 0 begin d# 0 over c! 1+ 2dup = until 2drop h# 400 cursor ! ; : emit vid-emit ; : space bl emit ; : cr d# 13 emit d# 10 emit ; : 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 ; : . hex4 space ; : snap [char] S emit [char] N emit [char] A emit [char] P emit cr hex4 cr hex4 cr hex4 cr hex4 cr hex4 cr hex4 cr hex4 cr hex4 cr begin again ; : CHAR+ 1+ ; : CHARS ; : PAUSE ; : +! ( n a -- )( 6.1.0130 ( 0x6C ) DUP >R @ + R> ! ; : COUNT ( a -- a c )( 6.1.0980 ( 0x84 ) DUP CHAR+ SWAP C@ ; : BOUNDS ( a u -- a+u a )( 0xAC ) OVER + SWAP ; : /STRING ( ca u n -- ca+n u-n )( 17.6.1.0245 ) SWAP OVER - >R CHARS + R> ; : TYPE ( ca u -- )( 6.1.2310 ( 0x90 ) PAUSE CHARS BOUNDS BEGIN 2DUP XOR WHILE COUNT EMIT REPEAT 2DROP ; : SAME? ( ca ca u -- f ) begin dup while >r over c@ upper over c@ upper <> if r> drop 2drop false ; then 1+ swap 1+ swap r> 1- repeat drop 2drop true ; : isimmediate ( xt -- f ) d# -3 + c@ h# 80 and 0<> ; : name? ( xt -- ca u ) d# -3 + dup c@ h# 7f and tuck - swap ; : sayword ( xt -- ) name? type ; : inch >in @ tib + ; : inch+1 d# 1 >in +! ; : execute fwd4 ! + ; : advance d# 1 /string d# 1 >in +! ; : skipbl ( ca u -- ca u ) \ skip blank chars begin over c@ bl = over 0<> and while advance repeat ; : skipnbl ( ca u -- ca u ) \ skip nonblank chars begin over c@ bl <> over 0<> and while advance repeat ; variable source/a variable source/l : source ( -- ca u )( 6.1.2216 ) source/a @ source/l @ ; : source>in source >in @ /string ; : parse-word ( -- ca u ) source>in skipbl over >r skipnbl drop r> tuck - ; \ name \ length \ prev \ cfa <--- xt \ args : here dp @ ; : c, here c! d# 1 dp +! ; : , here ! d# 2 dp +! ; : s, begin dup while over c@ c, d# 1 /string repeat 2drop ; the-link voc 0 ivariable state : head, ( "name" -- ) parse-word tuck s, c, voc @ , here voc ! ; : digit ( c -- u ) upper [CHAR] 0 - D# 9 OVER < IF D# 7 - DUP D# 10 < OR THEN ; : 1/string d# 1 /string ; : isnumber ( ca u -- f ) \ over c@ [char] - = if 1/string then true >r begin dup while over c@ digit base @ u< r> and >r 1/string repeat 2drop r> ; : asnumber ( ca u -- false | n true ) d# 0 >r begin dup while over c@ digit r> base @ * + >r 1/string repeat 2drop r> true ; : words voc @ begin dup while dup sayword space d# -2 + @ repeat cr ; : sfind ( ca u -- xt | ca u 0 ) >r voc @ begin dup while 2dup name? ( ca xt ca ca u ) dup r@ = if SAME? if r> drop nip ; then else 2drop drop then d# -2 + @ repeat drop r> false ; variable (quit) : interpret begin parse-word dup while sfind ?dup if dup isimmediate state @ 0= or if execute else , then else 2dup isnumber if state @ if '(lit) , asnumber drop , else asnumber drop then else [char] ? emit type (quit) @ execute then then repeat 2drop ; ( Gameduino system constants JCB 16:45 04/15/11) 0000 constant RAM_PIC 1000 constant RAM_CHR 2000 constant RAM_PAL 2800 constant IDENT 2801 constant REV 2802 constant FRAME 2803 constant VBLANK 2804 constant SCROLL_X 2806 constant SCROLL_Y 2808 constant JK_MODE 280a constant SPR_DISABLE 280b constant SPR_PAGE 280c constant IOMODE 280e constant BG_COLOR 2810 constant SAMPLE_L 2812 constant SAMPLE_R 2a00 constant VOICES 2840 constant PALETTE16A 2860 constant PALETTE16B 2880 constant PALETTE4A 2888 constant PALETTE4B 2890 constant COMM 2900 constant COLLISION 2c00 constant J1_CODE 3000 constant RAM_SPR 3800 constant RAM_SPRPAL 4000 constant RAM_SPRIMG \ screen \ 11 8016 constant FLASH_MISO 8018 constant FLASH_MOSI 801a constant FLASH_SCK 801c constant FLASH_SSEL ( SPI JCB 16:42 04/15/11) : off d# 0 swap c! ; : on d# 1 swap c! ; : spi-sel FLASH_SSEL off ; : spi-unsel FLASH_SSEL on ; : spi-cold spi-unsel FLASH_SCK off ; : spi-1bit ( u -- u ) \ single bit via SPI d# 2 * dup d# 8 rshift FLASH_MOSI c! \ write MSB to MOSI FLASH_SCK on \ raise clock FLASH_MISO c@ or \ read MISO into LSB FLASH_SCK off ; \ drop clock : spi-xfer ( u -- u ) spi-1bit spi-1bit spi-1bit spi-1bit spi-1bit spi-1bit spi-1bit spi-1bit ; : >spi spi-xfer drop ; ( Atmel flash JCB 07:32 04/16/11) \ http://www.atmel.com/dyn/resources/prod_documents/doc3638.pdf : flash-status spi-sel h# D7 spi-xfer spi-xfer spi-unsel ; : flash-ready? begin flash-status h# 80 and until ; : flash-page ( u -- ) \ 512*(572+u) d# 572 + dup d# 7 rshift >spi d# 2 * >spi d# 0 >spi ; : page>flash ( a u -- a' u' ) spi-sel h# 82 >spi tuck flash-page d# 264 bounds begin dup c@ >spi 1+ 2dup = until drop swap 1+ spi-unsel flash-ready? ; : blk>flash ( a u -- ) d# 4 * page>flash page>flash page>flash page>flash 2drop ; : flash>page ( u -- ) spi-sel h# 03 >spi flash-page h# 0 h# 400 bounds begin d# 0 spi-xfer over c! 1+ 2dup = until 2drop spi-unsel ; : interpret0 d# 0 begin >r d# 0 >in ! r@ source/a ! d# 64 source/l ! interpret r> h# 40 + dup h# 400 = until drop ; : load d# 4 * flash>page \ d# 1024 d# 0 begin dup c@ emit 1+ 2dup = until interpret0 ; variable blk : key begin CIN c@ ?dup until d# 0 CIN c! ; : . hex4 ; : quit begin cr begin d# 127 emit d# -1 cursor +! key dup d# 13 xor while emit repeat drop cursor @ h# ffc0 and cursor @ h# 003f and space d# 0 >in ! source/l ! source/a ! interpret space [char] o emit [char] k emit again ; : ( source>in begin over c@ [char] ) <> while advance repeat advance 2drop ; : nucok [char] N emit [char] U emit [char] C emit space [char] O emit [char] K emit cr ; \ : sec \ spi-sel 77 spi-xfer spi-xfer spi-xfer spi-xfer drop \ 80 begin 0 spi-xfer hex2 space next cr ; : f; semis# , d# 0 state ! ; immediate : : head, bc-col c, d# 1 state ! ; label main nucok [char] J IOMODE c! spi-cold d# 0 blk ! begin begin BLKRDY c@ until \ d# 0 blk @ blk>flash d# 1 blk +! interpret0 d# 0 BLKRDY c! again label blkmain nucok [char] J IOMODE c! spi-cold d# 0 begin dup >r load r> 1+ again label stump main dumpmem meta