123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729 |
- 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
|