Browse Source

Initial import

jamesbowman 8 years ago
parent
commit
5fba04ab97
30 changed files with 2925 additions and 2 deletions
  1. 4 0
      .gitignore
  2. 9 2
      README.md
  3. 61 0
      basewords.fs
  4. 32 0
      bgstripes.fs
  5. 91 0
      cold.fs
  6. 535 0
      crossj1.fs
  7. 25 0
      dna.fs
  8. 729 0
      eforth.fs
  9. 22 0
      eraser.fs
  10. 18 0
      flowtest.fs
  11. 22 0
      helloworld.fs
  12. 69 0
      hwdefs.fs
  13. 83 0
      main.fs
  14. 54 0
      memtest.fs
  15. 546 0
      nuc.fs
  16. 18 0
      palcopy.fs
  17. 14 0
      random.fs
  18. 25 0
      rasterinterrupt.fs
  19. 19 0
      regressfreq.fs
  20. 50 0
      reload.fs
  21. 142 0
      screens.fs
  22. 24 0
      selftest1.fs
  23. 31 0
      setpixel.fs
  24. 17 0
      showvoices.fs
  25. 33 0
      soundbuffer.fs
  26. 99 0
      spectrum.fs
  27. 29 0
      splitscreen.fs
  28. 13 0
      spr512.fs
  29. 42 0
      testflash.fs
  30. 69 0
      wireframe.fs

+ 4 - 0
.gitignore

@@ -0,0 +1,4 @@
+*.binbe
+*.binle
+*.h
+*.lst

+ 9 - 2
README.md

@@ -1,2 +1,9 @@
-# gd1-sdk
-SDK for the J1 coprocessor in the Gameduino 1
+# SDK for the J1 coprocessor in the Gameduino 1
+
+To compile all the samples run:
+
+gforth -e 'include main.fs bye'
+
+For more details on the Gameduino 1 coprocessor, see:
+
+http://excamera.com/sphinx/gameduino/coprocessor.html

+ 61 - 0
basewords.fs

@@ -0,0 +1,61 @@
+( Base words implemented in assembler        JCB 13:10 08/24/10)
+
+meta
+: noop      T                       alu ;
+: +         T+N                 d-1 alu ;
+: xor       T^N                 d-1 alu ;
+: and       T&N                 d-1 alu ;
+: or        T|N                 d-1 alu ;
+: invert    ~T                      alu ;
+: =         N==T                d-1 alu ;
+: <         N<T                 d-1 alu ;
+: u<        Nu<T                d-1 alu ;
+: swap      N     T->N              alu ;
+: dup       T     T->N          d+1 alu ;
+: drop      N                   d-1 alu ;
+: over      N     T->N          d+1 alu ;
+: nip       T                   d-1 alu ;
+: >r        N     T->R      r+1 d-1 alu ;
+: r>        rT    T->N      r-1 d+1 alu ;
+: r@        rT    T->N          d+1 alu ;
+: c@        T                       alu
+            [T]                     alu ;
+: c!        T     N->[T]        d-1 alu
+            N                   d-1 alu ;
+: rshift    N>>T                d-1 alu ;
+: *         N*T                 d-1 alu ;
+: swab      swabT                   alu ;
+: 1-        T-1                     alu ;
+: exit      return                      ;
+
+\ Elided words
+\ These words are supported by the hardware but are not
+\ part of ANS Forth.  They are named after the word-pair
+\ that matches their effect  The first word is one of
+\ 2dup, dup or over.  Using these elided words instead of
+\ the pair saves one cycle and one instruction.
+
+: 2dupand   T&N   T->N          d+1 alu ;
+: 2dup<     N<T   T->N          d+1 alu ;
+: 2dup=     N==T  T->N          d+1 alu ;
+: 2dup*     N*T   T->N          d+1 alu ;
+: 2dupor    T|N   T->N          d+1 alu ;
+: 2duprshift N>>T T->N          d+1 alu ;
+: 2dup+     T+N   T->N          d+1 alu ;
+: 2dupu<    Nu<T  T->N          d+1 alu ;
+: 2dupxor   T^N   T->N          d+1 alu ;
+: dup>r     T     T->R          r+1 alu ;
+: dupc@     T     T->N          d+1 alu
+            [T]                     alu ;
+: dupswab   swabT T->N          d+1 alu ;
+: overand   T&N                     alu ;
+: over>     N<T                     alu ;
+: over=     N==T                    alu ;
+: over*     N*T                     alu ;
+: overor    T|N                     alu ;
+: over+     T+N                     alu ;
+: overu>    Nu<T                    alu ;
+: overxor   T^N                     alu ;
+
+: module[ there [char] " parse preserve ;
+: ]module s" Compiled " type count type space there swap - . cr ;

+ 32 - 0
bgstripes.fs

@@ -0,0 +1,32 @@
+start-microcode bgstripes
+
+\ renders a 64-line horizontal stripe in the BG_COLOR
+\ starting at line COMM+0
+
+\ Interface:
+\ COMM+0    stripe start
+\ 3E80-3EFF 64 color stripe
+
+: 1+    d# 1 + ;
+: -     invert 1+ + ;
+: 0=    d# 0 = ;
+: @     dup c@ swap 1+ c@ swab or ;
+: !     over swab over 1+ c! c! ;
+: 2dup  over over ;
+: min   2dup < ;fallthru
+: ?:    ( xt xf flag -- xt | xf)    \ if flag xt, else xf
+        if drop else nip then ;
+: max   2dup swap < ?: ;
+
+: main
+    begin
+        YLINE c@            \ line COMM+0 is line zero
+        COMM+0 c@ -
+        d# 0 max d# 63 min  \ clamp to 0-63
+        d# 2 * h# 3E80 +    \ index into color table
+        @ BG_COLOR !        \ fetch and write
+    again
+;
+
+end-microcode
+

+ 91 - 0
cold.fs

@@ -0,0 +1,91 @@
+start-microcode cold
+
+\ system cold start program
+
+\ Interface:
+\ 3400-34FF voices source
+\ 3800-3FFF palette animation source (64 palettes)
+
+h# 3400 constant VOICES_COPY
+h# 3800 constant PALETTES
+
+d# 32   constant PALSZ      \ size of palette in bytes
+
+: vblank@
+        VBLANK ;fallthru
+: _c@   c@ ;                \ these save 1 instruction per use
+: _c!   c! ;
+: 1+    d# 1 + ;
+: @     dup _c@ swap 1+ _c@ swab or ;
+: up1 ( a -- ) \ subtract 1 from sprite coordinate at a
+        dup>r @ dup h# fe00 and swap 1- h# 1FF and or r> ;fallthru
+: !     ( u addr )
+        over swab over 1+ _c! _c! ;
+
+: waitvbi   \ wait for start of vertical blanking interval
+    begin vblank@ 1- until
+    begin vblank@ until ;
+
+: stepfade ( u -- ) \ fade step u is 0-63
+    PALSZ * PALETTES +
+    dup d# 30 + @ BG_COLOR !    \ copy 15th palette entry to BG_COLOR
+    PALETTE16A
+    PALSZ
+;fallthru
+: cmove ( src dst n -- )
+    begin
+        dup
+    while
+        >r
+        over _c@ over _c!
+        1+ swap 1+ swap
+        r> 1-
+    repeat
+    drop ;fallthru
+: 2drop drop drop ;
+
+: endl ( limit u -- limit u' finished ) \ end of loop
+    waitvbi ;fallthru
+: qendl \ quick endl, no wait for frame
+    1+
+    2dup=
+;
+
+: >VOICES ( a -- ) \ load all voices from a
+    VOICES d# 256 cmove ;
+
+[ RAM_SPR 2 + ] constant SPR_YS \ sprite Y coordinates
+
+: main
+    d# 256 d# 0
+    begin
+        dup h# c0 and d# 128 = if
+            dup d# 63 and stepfade
+        then
+        \ copy 3E00+u to VOICES+u
+        dup VOICES_COPY + _c@
+        over VOICES + _c!
+    endl until
+    begin 
+        COMM+9 _c@
+    until
+    h# 3500 >VOICES 
+    d# 265 d# 0
+    begin
+        d# 256 d# 0
+        begin
+            dup d# 4 * SPR_YS + up1
+        qendl until
+        2drop
+        dup SCROLL_Y !
+    endl until
+    h# 3600 >VOICES 
+    d# 0
+    begin
+        waitvbi 
+        dup SCROLL_X !
+        1+
+    again
+;
+
+end-microcode

+ 535 - 0
crossj1.fs

@@ -0,0 +1,535 @@
+( Cross-compiler for the J1                  JCB 13:12 08/24/10)
+decimal
+
+( outfile is fileid or zero                  JCB 12:30 11/27/10)
+
+0 value outfile
+
+: type ( c-addr u )
+    outfile if
+        outfile write-file throw
+    else
+        type
+    then
+;
+: emit ( u )
+    outfile if
+        pad c! pad 1 outfile write-file throw
+    else
+        emit
+    then
+;
+: cr ( u )
+    outfile if
+        s" " outfile write-line throw
+    else
+        cr
+    then
+;
+: space bl emit ;
+: spaces dup 0> if 0 do space loop then ;
+
+vocabulary j1assembler  \ assembly storage and instructions
+vocabulary metacompiler \ the cross-compiling words
+vocabulary j1target     \ actual target words
+
+: j1asm
+    only
+    metacompiler
+    also j1assembler definitions
+    also forth ;
+: meta
+    only
+    j1target also
+    j1assembler also
+    metacompiler definitions also
+    forth ;
+: target
+    only
+    metacompiler also
+    j1target definitions ;
+
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
+
+j1asm
+
+: tcell 2 ;
+: tcells tcell * ;
+: tcell+ tcell + ;
+65536 allocate throw constant tflash
+
+: h#
+    base @ >r 16 base !
+    0. bl parse >number throw 2drop postpone literal
+    r> base ! ; immediate
+
+variable tdp
+: there     tdp @ ;
+: islegal   dup h# 7fff u> abort" illegal address" ;
+: tc!       islegal tflash + c! ;
+: tc@       islegal tflash + c@ ;
+: t!        islegal over h# ff and over tc! swap 8 rshift swap 1+ tc! ;
+: t@        islegal dup tc@ swap 1+ tc@ 8 lshift or ;
+: talign    tdp @ 1 + h# fffe and tdp ! ;
+: tc,       there tc! 1 tdp +! ;
+: t,        there t! tcell tdp +! ;
+: org       tdp ! ;
+
+65536 cells allocate throw constant references
+: referenced cells references + 1 swap +! ;
+
+65536 cells allocate throw constant labels
+: atlabel? ( -- f = are we at a label )
+    labels there cells + @ 0<>
+;
+
+: coldcross
+    tflash 65536 255 fill
+    labels 65536 cells 0 fill
+;
+
+coldcross
+
+: preserve  ( c-addr1 u -- c-addr )
+    dup 1+ allocate throw dup >r
+    2dup c! 1+
+    swap cmove r> ;
+
+: setlabel ( c-addr u -- )
+    atlabel? if 2drop else preserve labels there cells + ! then ;
+
+j1asm
+
+: hex-literal ( u -- c-addr u ) s>d <# bl hold #s [char] $ hold #> ;
+
+: imm h# 8000 or t, ;
+
+: T         h# 0000 ;
+: N         h# 0100 ;
+: T+N       h# 0200 ;
+: T&N       h# 0300 ;
+: T|N       h# 0400 ;
+: T^N       h# 0500 ;
+: ~T        h# 0600 ;
+: N==T      h# 0700 ;
+: N<T       h# 0800 ;
+: N>>T      h# 0900 ;
+: T-1       h# 0a00 ;
+: rT        h# 0b00 ;
+: [T]       h# 0c00 ;
+: N*T       h# 0d00 ;
+: swabT     h# 0e00 ;
+: Nu<T      h# 0f00 ;
+
+: T->N      h# 0080 or ;
+: T->R      h# 0040 or ;
+: N->[T]    h# 0020 or ;
+: d-1       h# 0003 or ;
+: d+1       h# 0001 or ;
+: r-1       h# 000c or ;
+: r-2       h# 0008 or ;
+: r+1       h# 0004 or ;
+
+: alu       h# 6000 or t, ;
+
+: return    T  h# 1000 or r-1 alu ;
+: ubranch   2/ h# 0000 or t, ;
+: 0branch   2/ h# 2000 or t, ;
+: scall     2/ h# 4000 or t, ;
+
+: dump-words ( c-addr n -- ) \ Write n/2 words from c-addr
+    dup 6 > abort" invalid byte count"
+    2/ dup >r
+    0 do
+        dup t@ s>d <# # # # # #> type space
+        2 +
+    loop drop
+    3 r> - 5 * spaces
+;
+
+variable padc
+: pad+ ( c-addr u -- ) \ append to pad
+    dup >r
+    pad padc @ + swap cmove
+    r> padc +! ;
+
+: pad+loc  ( addr -- )
+    dup cells labels + @ ?dup if
+        nip count pad+
+    else
+        s>d <# #s [char] $ hold #> pad+
+    then
+    s"  " pad+
+;
+
+
+: disassemble-j
+    0 padc !
+    dup t@ h# 8000 and if
+        s" LIT " pad+
+        dup t@ h# 7fff and hex-literal pad+ exit
+    else
+        dup t@ h# e000 and h# 6000 = if
+            s" ALU " pad+
+            dup t@ pad+loc exit
+        else
+            dup t@ h# e000 and h# 4000 = if
+                s" CALL "
+            else
+                dup t@ h# 2000 and if 
+                    s" 0BRANCH "
+                else
+                    s" BRANCH "
+                then
+            then
+            pad+
+            dup t@ h# 1fff and 2* pad+loc
+        then
+    then
+;
+
+: disassemble-line ( offset -- offset' )
+    dup cells labels + @ ?dup if s" \ " type count type cr then
+    dup s>d <# # # # # #> type space 
+    dup 2 dump-words
+    disassemble-j
+    pad padc @ type
+    2 + 
+    cr
+;
+
+: disassemble-block
+    0 do
+        disassemble-line
+    loop
+    drop
+;
+
+j1asm
+
+\ tcompile is like "STATE": it is true when compiling
+
+variable tcompile
+: tcompile? tcompile @ ;
+: +tcompile tcompile? abort" Already in compilation mode" 1 tcompile !  ;
+: -tcompile 0 tcompile ! ;
+
+: (literal)
+    \ dup $f rshift over $e rshift xor 1 and throw
+    dup h# 8000 and if
+        h# ffff xor recurse
+        ~T alu
+    else
+        h# 8000 or t,
+    then
+
+;
+: (t-constant)
+    tcompile? if
+        (literal)
+    then
+;
+
+meta
+
+\ Find name - without consuming it - and return a counted string
+: wordstr ( "name" -- c-addr u )
+    >in @ >r bl word count r> >in !
+;
+
+
+: literal (literal) ; immediate
+: 2literal swap (literal) (literal) ; immediate
+: call,
+    dup referenced
+    scall
+;
+
+: t:
+    talign
+    wordstr setlabel
+    create
+        there ,
+        +tcompile 
+        947947
+    does>
+        @
+        tcompile? if
+            call,
+        then
+;
+
+: lookback ( offset -- v ) there swap - t@ ;
+: prevcall?  2 lookback h# e000 and h# 4000 = ;
+: call>goto dup t@ h# 1fff and swap t! ;
+: prevsafe?
+    2 lookback h# e000 and h# 6000 =    \ is an ALU
+    2 lookback h# 004c and 0= and ;   \ does not touch RStack
+: alu>return dup t@ h# 1000 or r-1 swap t! ;
+
+: t; 947947 <> if abort" Unstructured" then
+    true if
+        atlabel? invert prevcall? and if
+            there 2 - call>goto
+        else
+            atlabel? invert prevsafe? and if
+                there 2 - alu>return
+            else
+                return
+            then
+        then
+    else
+        return
+    then
+    -tcompile
+;
+
+: t;fallthru 947947 <> if abort" Unstructured" then
+    -tcompile
+;
+
+variable shadow-tcompile
+wordlist constant escape]-wordlist
+escape]-wordlist set-current
+: ] shadow-tcompile @ tcompile ! previous previous ;
+
+meta
+
+: [ 
+    tcompile @ shadow-tcompile !
+    -tcompile get-order forth-wordlist escape]-wordlist rot 2 + set-order
+;
+
+: : t: ;
+: ; t; ;
+: ;fallthru t;fallthru ;
+: , t, ;
+: c, tc, ;
+
+: constant ( n "name" -- ) create , immediate does> @ (t-constant) ;
+
+: ]asm 
+    -tcompile also forth also j1target also j1assembler ;
+: asm[ +tcompile previous previous previous ;
+: code t: ]asm ;
+
+j1asm
+
+: end-code
+    947947 <> if abort" Unstructured" then
+    previous previous previous ;
+
+meta
+
+\ Some Forth words are safe to use in target mode, so import them
+
+: ( postpone ( ;
+: \ postpone \ ;
+
+: import ( "name" -- )
+    >in @ ' swap >in !
+    create , does> @ execute ;
+
+import meta
+import org
+import include
+import included
+import marker
+import [if]
+import [else]
+import [then]
+
+: do-number ( n -- |n )
+    state @ if
+        postpone literal
+    else
+        tcompile? if
+            (literal)
+        then
+    then
+;
+
+decimal
+
+: [char] ( "name" -- ) ( run: -- ascii) char (literal) ;
+
+: ['] ( "name" -- ) ( run: -- xt )
+    ' tcompile @ >r -tcompile execute r> tcompile !
+    dup referenced
+    (literal)
+;
+
+: (sliteral--h) ( addr n -- ptr ) ( run: -- eeaddr n )
+    s" sliteral" evaluate
+    there >r
+    dup tc,
+    0 do count tc, loop
+    drop
+    talign
+    r>
+;
+
+: (sliteral) (sliteral--h) drop ;
+: s" ( "ccc<quote>" -- ) ( run: -- eaddr n ) [char] " parse (sliteral) ;
+: s' ( "ccc<quote>" -- ) ( run: -- eaddr n ) [char] ' parse (sliteral) ;
+
+: create
+    wordstr setlabel
+    create  there ,
+    does>   @ do-number
+;
+
+: allot     tdp +! ;
+
+: variable  wordstr setlabel create there , 0 t,
+            does> @ do-number ;
+: 2variable  wordstr setlabel create there , 0 t, 0 t,
+            does> @ do-number ;
+
+: createdoes
+    wordstr setlabel
+    create there , ' ,
+    does> dup @ dup referenced (literal) cell+ @ execute
+;
+
+: jumptable 
+    wordstr setlabel
+    create there ,
+    does> s" 2*" evaluate @ dup referenced (literal) s" + @" evaluate
+;
+
+: | ' execute dup referenced t, ;
+
+: ', ' execute t, ;
+
+( DEFER                                      JCB 11:18 11/12/10)
+
+: defer
+    wordstr setlabel
+    create there , 0 t,
+    does> @ tcompile? if do-number s" @ execute" evaluate then ;
+
+: is ( xt "name" -- )
+    tcompile? if
+        ' >body @ do-number
+        s" ! " evaluate
+    else
+        ' execute t!
+    then ;
+
+: ' ' execute ;
+
+( VALUE                                      JCB 13:06 11/12/10)
+
+: value
+    wordstr setlabel
+    create there , t,
+    does> @ do-number s" @" evaluate ;
+
+: to ( u "name" -- )
+    ' >body @ do-number s" !" evaluate ;
+
+( ARRAY                                      JCB 13:34 11/12/10)
+
+: array
+    wordstr setlabel
+    create there , 0 do 0 t, loop
+    does> s" cells" evaluate @ do-number s" +" evaluate ;
+: 2array
+    wordstr setlabel
+    create there , 2* 0 do 0 t, loop
+    does> s" 2* cells" evaluate @ do-number s" +" evaluate ;
+
+( eforth's way of handling constants         JCB 13:12 09/03/10)
+
+: label: ( "name" -- ) create there , immediate does> @ (t-constant) ;
+
+: sign>number
+    over c@ [char] - = if
+        1- swap 1+ swap
+        >number
+        2swap dnegate 2swap
+    else
+        >number
+    then
+;
+
+: base>number ( caddr u base -- )
+    base @ >r base !
+    sign>number
+    r> base !
+    dup 0= if
+        2drop drop do-number
+    else
+        1 = swap c@ [char] . = and if
+            drop dup do-number 16 rshift do-number
+        else
+            -1 abort" bad number"
+        then
+    then ;
+
+: d# 0. bl parse 10 base>number ;
+: h# 0. bl parse 16 base>number ;
+
+( Conditionals                               JCB 13:12 09/03/10)
+: if
+    there
+    0 0branch
+;
+
+: resolve
+    dup t@ there 2/ or swap t!
+;
+
+: then
+    resolve
+    s" (then)" setlabel
+;
+
+: else
+    there
+    0 ubranch 
+    swap resolve
+    s" (else)" setlabel
+;
+
+
+: begin s" (begin)" setlabel there ;
+: again 
+    ubranch
+;
+: until
+    0branch
+;
+: while
+    there
+    0 0branch
+;
+: repeat
+    swap ubranch
+    resolve
+    s" (repeat)" setlabel
+;
+
+: 0do    s" >r d# 0 >r"     evaluate there s" (do)" setlabel ;
+: do     s" 2>r"         evaluate there s" (do)" setlabel ;
+: loop
+    s" looptest" evaluate 0branch
+;
+: i     s" r@" evaluate ;
+
+77 constant sourceline#
+s" none" 2constant sourcefilename
+
+: line# sourceline# (literal) ;
+create currfilename 1 cells 80 + allot
+variable currfilename#
+: savestr ( c-addr u dst -- ) 2dup c! 1+ swap cmove ;
+: getfilename sourcefilename currfilename count compare 0<>
+    if
+        sourcefilename 2dup currfilename savestr (sliteral--h) currfilename# !
+    else
+        currfilename# @ dup 1+ (literal) tc@ (literal)
+    then ;
+: snap line# getfilename s" (snap)" evaluate ; immediate
+: assert 0= if line# sourcefilename (sliteral) s" (assert)" evaluate then ; immediate

+ 25 - 0
dna.fs

@@ -0,0 +1,25 @@
+start-microcode dna
+
+: 1+ d# 1 + ;
+: 2* d# 2 * ;
+
+: dna@      ( -- u )    h# 8018 c@ ;
+: dna!      ( u -- )    h# 8008 c! ;
+: dnaclk    ( u -- )    dup dna! 1+ dna! ;
+: dnaread   ( )         d# 4 dnaclk ;
+: dnashift  ( )         d# 2 dnaclk ;
+: dnabit    ( u -- u )  2* dna@ + dnashift ;
+: dnabyte   ( -- u )    \ read byte from DNA
+    d# 0
+    dnabit dnabit dnabit dnabit
+    dnabit dnabit dnabit dnabit ;
+: main       \ write 7 byte DNA to COMM
+    dnaread dnashift
+    COMM+7 COMM+0
+    begin
+        dnabyte over c!
+        1+ 2dup=
+    until
+    begin again ;
+
+end-microcode

+ 729 - 0
eforth.fs

@@ -0,0 +1,729 @@
+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

+ 22 - 0
eraser.fs

@@ -0,0 +1,22 @@
+start-microcode eraser
+
+COMM+8 constant mask
+
+: main
+
+    mask c@ >r
+    h# 3FFF h# 7FFF \ RAM_SPRIMG, from top to bottom
+    begin
+        dupc@ r@ and
+        over c!
+        1- 2dup=
+    until
+
+    \ tell host we're done
+    d# 0 COMM+7 c!
+    \ hang
+    begin again
+;
+
+end-microcode
+

+ 18 - 0
flowtest.fs

@@ -0,0 +1,18 @@
+start-microcode flowtest
+
+: main
+    begin
+        \ wait until COMM+0 is nonzero
+        begin
+            COMM+0 c@
+        until
+
+        \ increment COMM+1
+        COMM+1 c@ d# 1 + COMM+1 c!
+
+        \ write zero to COMM+0, telling host we're done
+        d# 0 COMM+0 c!
+    again
+;
+
+end-microcode

+ 22 - 0
helloworld.fs

@@ -0,0 +1,22 @@
+start-microcode helloworld
+: 1+ d# 1 + ;
+: writechar ( addr ch -- addr' )
+    over c! 1+ ;
+
+: main
+    d# 512             \ lines are 64 characters, so this is line 8
+    [char] H writechar
+    [char] E writechar
+    [char] L writechar
+    [char] L writechar
+    [char] O writechar
+    1+
+    [char] W writechar
+    [char] O writechar
+    [char] R writechar
+    [char] L writechar
+    [char] D writechar
+    begin again
+;
+
+end-microcode

+ 69 - 0
hwdefs.fs

@@ -0,0 +1,69 @@
+( Hardware register definitions              JCB 11:36 01/23/11)
+
+h# 0000 constant RAM_PIC        \ Screen Picture, 64 x 64 = 4096 bytes
+h# 1000 constant RAM_CHR        \ Screen Characters, 256 x 16 = 4096 bytes
+h# 2000 constant RAM_PAL        \ Screen Character Palette, 256 x 8 = 2048 bytes
+h# 2800 constant IDENT
+h# 2801 constant REV
+h# 2802 constant FRAME       
+h# 2803 constant VBLANK      
+h# 2804 constant SCROLL_X    
+h# 2805 constant SCROLL_Xhi
+h# 2806 constant SCROLL_Y    
+h# 2807 constant SCROLL_Yhi
+h# 2808 constant JK_MODE     
+h# 2809 constant J1_RESET
+h# 280a constant SPR_DISABLE
+h# 280b constant SPR_PAGE
+h# 280c constant IOMODE
+h# 280e constant BG_COLOR
+h# 2810 constant SAMPLE_Llo
+h# 2811 constant SAMPLE_Lhi
+h# 2812 constant SAMPLE_Rlo
+h# 2813 constant SAMPLE_Rhi
+
+h# 2a00 constant VOICES      
+h# 2840 constant PALETTE16A     \ 16-color palette RAM A, 32 bytes
+h# 2860 constant PALETTE16B     \ 16-color palette RAM B, 32 bytes
+h# 2880 constant PALETTE4A      \ 4-color palette RAM A, 8 bytes
+h# 2888 constant PALETTE4B      \ 4-color palette RAM A, 8 bytes
+h# 2890 constant COMM           \ Communication buffer
+h# 2900 constant COLLISION      \ Collision detection RAM, 256 bytes
+h# 2b00 constant J1_CODE        \ J1 coprocessor microcode RAM
+h# 3000 constant RAM_SPR        \ Sprite Control, 512 x 4 = 2048 bytes
+h# 3800 constant RAM_SPRPAL     \ Sprite Palettes, 4 x 256 = 2048 bytes
+h# 4000 constant RAM_SPRIMG     \ Sprite Image, 64 x 256 = 16384 bytes
+
+[ COMM 0 + ] constant COMM+0
+[ COMM 1 + ] constant COMM+1
+[ COMM 2 + ] constant COMM+2
+[ COMM 3 + ] constant COMM+3
+[ COMM 4 + ] constant COMM+4
+[ COMM 5 + ] constant COMM+5
+[ COMM 6 + ] constant COMM+6
+[ COMM 7 + ] constant COMM+7
+[ COMM 8 + ] constant COMM+8
+[ COMM 9 + ] constant COMM+9
+[ COMM 10 + ] constant COMM+10
+[ COMM 11 + ] constant COMM+11
+[ COMM 12 + ] constant COMM+12
+[ COMM 13 + ] constant COMM+13
+[ COMM 14 + ] constant COMM+14
+[ COMM 15 + ] constant COMM+15
+
+( Locations for coprocessor only             JCB 11:45 02/06/11)
+
+h# 8000 constant YLINE
+h# 8002 constant ICAP_O
+h# 8004 constant ICAP_BUSY
+h# 8006 constant ICAP_PORT      \ see reload.fs for details
+h# 800a constant FREQHZ
+h# 800c constant FREQTICK
+h# 800e constant P2_V
+h# 8010 constant P2_DIR
+h# 8012 constant RANDOM
+h# 8014 constant CLOCK
+h# 8016 constant FLASH_MISO
+h# 8018 constant FLASH_MOSI
+h# 801a constant FLASH_SCK
+h# 801c constant FLASH_SSEL

+ 83 - 0
main.fs

@@ -0,0 +1,83 @@
+include crossj1.fs
+
+variable filebase
+
+: suffix ( addr u -- addr u ) \ append suffix to basename
+    0 padc !
+    filebase @ count pad+
+    pad+
+    pad padc @
+;
+: create-output-file w/o create-file throw to outfile ;
+: cbyte s" 0x" type s>d <# # # #> type [char] , emit ;
+hex
+variable hiaddr
+: coderange hiaddr @ 2B00 ;
+: dumpall \ dump the target memory in every useful format
+    hex
+
+    \ .lst file is a human-readable disassembly 
+    s" .lst" suffix create-output-file
+    coderange tuck - 2/ disassemble-block
+
+    \ .binbe is a big-endian binary memory dump
+    s" .binbe" suffix create-output-file
+    coderange do i t@ dup 8 rshift emit emit 2 +loop
+
+    \ .binle is a little-endian binary memory dump
+    s" .binle" suffix create-output-file
+    coderange do i t@ dup emit 8 rshift emit 2 +loop
+
+    \ .h is a little-endian memory dump of bytes 2B00-2BFF
+    s" .h" suffix create-output-file
+    s" static PROGMEM prog_uchar " type
+    filebase @ count type
+    s" _code[] = {" type cr
+    coderange do i t@ dup cbyte 8 rshift cbyte cr 2 +loop
+    s" };" type cr
+;
+decimal
+: start-microcode
+    bl parse preserve filebase !
+    s" marker revert h# 2B02 org" evaluate
+    coldcross decimal
+;
+: end-microcode 
+    there hiaddr !
+    s" h# 2B00 org code 0jump main ubranch end-code revert meta" evaluate
+    dumpall
+    s" target" evaluate
+;
+
+meta
+coldcross
+include basewords.fs
+target
+include hwdefs.fs
+
+\ Build all these microcode files:
+
+include memtest.fs
+include helloworld.fs
+include flowtest.fs
+include setpixel.fs
+include wireframe.fs
+include eraser.fs
+include splitscreen.fs
+include selftest1.fs
+include reload.fs
+include palcopy.fs
+include random.fs
+include rasterinterrupt.fs
+include soundbuffer.fs
+include cold.fs
+include testflash.fs
+include bgstripes.fs
+include dna.fs
+include regressfreq.fs
+include showvoices.fs
+include spectrum.fs
+include spr512.fs
+\ include eforth.fs
+
+meta

+ 54 - 0
memtest.fs

@@ -0,0 +1,54 @@
+start-microcode memtest
+
+32 constant sp
+0 constant false ( 6.2.1485 )
+: 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 ;
+: 2*        d# 2 * ;
+
+: summit
+    h# 0 c@
+    h# 1 c@ +
+    h# 2 c@ +
+    h# 3 c@ +
+    h# 4 c@ +
+    h# 5 c@ +
+    h# 6 c@ +
+    h# 7 c@ +
+    h# 8 c@ +
+    h# 9 c@ +
+    d# 765
+    \ d# 550
+    over xor
+    if
+        h# DEAD begin again
+    else
+        drop
+    then
+;
+
+: move ( c-addr1 c-addr2 u -- )
+    begin
+        >r
+        over noop noop c@ over c!
+        1+ swap 1+ swap
+        r> 1- dup 0=
+    until
+    drop 2drop
+;
+
+: main
+    begin
+        h# 0 h# 16 d# 10 move
+        h# 16 h# 0 d# 10 move
+        summit
+    again
+;
+
+end-microcode

+ 546 - 0
nuc.fs

@@ -0,0 +1,546 @@
+( 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
+
+1 [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

+ 18 - 0
palcopy.fs

@@ -0,0 +1,18 @@
+start-microcode palcopy
+
+: 1+ d# 1 + ;
+
+: main
+    \ Copy RAM_PAL to PALETTE16A
+    RAM_PAL PALETTE16A
+    d# 32
+    begin
+        >r
+        over c@ over c!
+        1+ swap 1+ swap
+        r> 1- d# 0 =
+    until
+    begin again
+;
+
+end-microcode

+ 14 - 0
random.fs

@@ -0,0 +1,14 @@
+start-microcode random
+
+\ Fill PICTURE and CHARACTER RAM with random numbers
+
+: main
+    d# 0
+    begin
+        RANDOM c@ over c!
+        1-
+        h# 1FFF and
+    again
+;
+
+end-microcode

+ 25 - 0
rasterinterrupt.fs

@@ -0,0 +1,25 @@
+start-microcode rasterinterrupt
+
+: 1+ d# 1 + ;
+: @     dup c@ swap 1+ c@ swab or ;
+
+\ COMM+0 holds the 16 bit raster line number:
+\   0 is first line of screen
+\ 299 is last visible line of screen
+\ 300 is beginning of vertical blanking
+\
+\ This microprogram loop raises P2 when the raster is below line COMM+0,
+\ so the Arduino can trigger an interrupt
+
+: main
+    d# 0 P2_DIR c!          \ Make P2 an output
+                            \ Drive P2 high when raster is past line COMM+0
+    begin
+        COMM+0 @            \ user value
+        YLINE c@            \ hardware line
+        <                   \ true when hardware line is below user value
+        P2_V c!             \ write bool to P2
+    again
+;
+
+end-microcode

+ 19 - 0
regressfreq.fs

@@ -0,0 +1,19 @@
+start-microcode regressfreq
+
+\ Reads 16-bit frequency from COMM, generates square
+\ wave at half frequency PIN2
+
+: 1+    d# 1 + ;
+: @     dup c@ swap 1+ c@ swab or ;
+: !     over swab over 1+ c! c! ;
+
+: main
+    d# 0 P2_DIR c!          \ Make P2 an output
+                            \ Drive P2 high when raster is past line COMM+0
+    COMM+0 @ FREQHZ c!
+    begin
+        FREQTICK c@ P2_V c!
+    again
+;
+
+end-microcode

+ 50 - 0
reload.fs

@@ -0,0 +1,50 @@
+start-microcode reload
+
+\ This short microprogram forces a full chip reset, just like a power-cycle
+
+\ it talks to the Spartan 3A's ICAP interface to cause a full FPGA reload,
+\ as described in
+\ http://www.xilinx.com/support/documentation/user_guides/ug332.pdf page 278
+
+\ ICAP data bus is bit-reversed!
+: rev1 ( a b -- a' b' ) d# 2 * over d# 1 and + swap d# 1 rshift swap ;
+: rev8 d# 0 rev1 rev1 rev1 rev1 rev1 rev1 rev1 rev1 nip ;
+
+\ The ICAP_PORT low 8 bits are the reversed ICAP_I byte.
+\ Bits 8,9,10 are:
+
+h# 100 constant ICAP-CLK        \ 1,0 is a pulse
+h# 200 constant ICAP-CE         \ 0 means select
+h# 400 constant ICAP-WRITE      \ 0 means write
+
+: ICAP!
+    ICAP_PORT c! ;
+
+: >cicap ( v -- )    \ clock byte v into ICAP
+    rev8 dup ICAP! ICAP-CLK or ICAP! ;
+
+: >icap ( v -- ) \ 16-bit ICAP write
+    dup swab >cicap >cicap ;
+
+: icap_reload
+    h# ffff >icap
+    h# aa99 >icap
+    h# 3261 >icap
+    h# 0000 >icap
+    h# 3281 >icap
+    h# 0000 >icap
+
+    h# 30a1 >icap
+    h# 000e >icap
+    h# 2000 >icap
+    h# 2000 >icap \ needs extra NOOP to complete reboot
+;
+
+: main
+    h# 0 ICAP!
+
+    icap_reload
+    begin again
+;
+
+end-microcode

+ 142 - 0
screens.fs

@@ -0,0 +1,142 @@
+( 00:                                        JCB 08:33 04/24/11)
+: immediate voc @ 3 - dup c@ 80 or swap c! f;
+: ; semis# , 0 state ! f; immediate
+: exit semis# , ; immediate
+: \ source nip >in ! ; immediate
+: allot     dp +! ;
+: create    head, bc-var# c, ;
+: variable  head, bc-var# c, 0 , ;
+: 2variable head, bc-var# c, 0 , 0 , ;
+: constant  head, bc-const# c, , ;
+: compile,  , ;
+: cell+ 2 + ;  : 2* 2 * ; : cells 2* ;
+
+( 01: branching                              JCB 08:15 04/24/11)
+: ahead     branch# , here 7777 , ;
+: 0ahead    0branch# , here 7777 , ;
+: resolve   here swap ! ; \ resolve stacked ref to HERE
+: begin     here ; immediate
+: again     branch# , , ; immediate
+: until     0branch# , , ; immediate
+: while     0ahead ; immediate
+: repeat    swap branch# , , resolve ; immediate
+: if        0ahead ; immediate
+: else      ahead swap resolve ; immediate
+: then      resolve ; immediate
+
+( 02: parse                                  JCB 08:16 04/24/11)
+: parse \ ( char -- ca u )
+    source>in
+    advance
+    over >r
+    rot >r
+    begin
+        over c@ r@ <> over 0<> and
+    while
+        advance
+    repeat
+    r> 2drop
+    r> tuck - 1 >in +!
+;
+
+( 03: compilation                            JCB 08:17 04/24/11)
+: [         0 state ! ; immediate
+: ]         1 state ! ;
+: literal   literal# , , ; immediate
+: char      parse-word drop c@ ;
+: '         parse-word sfind ;
+: [']       literal# , ' , ; immediate
+: postpone
+    parse-word sfind
+    dup isimmediate invert if
+        literal# , , ['] ,
+    then , ; immediate
+: [char]    char postpone literal ; immediate
+: (         [char] ) parse 2drop ; immediate
+: halt      begin again ;  ' halt (quit) !
+
+( 04: debug                                  JCB 08:17 04/24/11)
+: dump 
+    over hex4 bounds
+    begin 2dup xor
+    while space dup c@ hex2 1+
+    repeat 2drop cr ;
+: isxt voc @ begin 2dup = if 2drop true exit then
+    2 - @ dup 0= until nip ;
+: typext dup isxt if name? type else hex4 then ;
+: seelast   [char] : emit space voc @ name? type
+    here voc @ 1+ begin
+        2dup xor
+    while space dup @ typext cell+
+    repeat cr 2drop ;
+
+( 05: strings                                JCB 08:17 04/24/11)
+: (sliteral)
+    r> count 2dup + >r ;
+: s"
+    [char] " parse
+    postpone (sliteral) dup c, s, ; immediate
+: ." postpone s" postpone type ; immediate
+: .( [char] ) parse type cr ; immediate
+: (next)    1- ?dup 0= ;
+: next      postpone (next) postpone until ; immediate
+
+( 06: move                                   JCB 08:18 04/24/11)
+: cmove ( c-addr1 c-addr2 u -- )
+    begin
+        dup
+    while
+        >r over c@ over c!
+        1+ swap 1+ swap
+        r> 1-
+    repeat
+    drop 2drop
+;
+
+( 07: create does>                           JCB 08:18 04/24/11)
+: (create)  r> cell+ ;
+: (does)    r> dup cell+ swap @ >r ;
+: create
+    head, bc-col# c,
+    ['] (create) , 0 , ;
+: does>
+    r> voc @ 1+
+    ['] (does) over ! cell+ ! ;
+: :noname
+    here bc-col# c, ] ;
+
+( 08: welcome                                JCB 08:18 04/24/11)
+\ screen \ 8
+.( gdforth 0.0.1)
+here hex4 cr
+' quit (quit) !
+
+( 09: DNA                                    JCB 08:19 04/24/11)
+: dna@      ( -- u )    8018 c@ ;
+: dna!      ( u -- )    8008 c! ;
+: dnaclk    ( u -- )    dup dna! 1+ dna! ;
+: dnaread   ( )         4 dnaclk ;
+: dnashift  ( )         2 dnaclk ;
+: dnabit    ( u -- u )  2* dna@ + dnashift ;
+: dnabyte   ( -- u )    \ read byte from DNA
+    0 8 begin >r dnabit r> next ;
+: dna       ( ca -- )   \ write 7 byte DNA at ca
+    dnaread dnashift
+    7 begin
+        >r dnabyte over c! 1+ r>
+    next drop ;
+\ 7F00 dna 7F00 7 dump
+( 10: SPI and flash                          JCB 08:19 04/24/11)
+char J IOMODE c!  spi-cold
+\ flash-status hex2 cr
+: showblk ( u -- )
+    spi-sel
+    03 >spi
+    flash-page
+    400 400 bounds begin
+        0 spi-xfer over c!
+        1+ 2dup =
+    until 2drop spi-unsel ;
+\ 0 showblk
+\ here hex4 cr
+quit

+ 24 - 0
selftest1.fs

@@ -0,0 +1,24 @@
+start-microcode selftest1
+: 1+ d# 1 + ;
+: ! ( u addr )
+    over swab over 1+ c! c! ;
+: d1+
+    swap 1+
+    swap over
+    d# 0 = if
+        1+
+    then
+;
+
+\ increment COMM+0,1,2,3 until COMM+15 goes high
+: main
+    h# 0.
+    begin
+        over COMM+0 !
+        dup COMM+2 !
+        d1+
+        begin COMM+15 c@ until
+    again
+;
+
+end-microcode

+ 31 - 0
setpixel.fs

@@ -0,0 +1,31 @@
+start-microcode setpixel
+
+: setpixel ( yx -- ) \ set pixel yx to color from COMM+2, about 35 cycles
+    dup>r
+    h# f and
+    r@ d# 4 rshift h# 0ff0 and or
+    r@ h# 30 and swab or
+    RAM_SPRIMG or ( addr )
+    dupc@ ( addr v )
+    h# c0 r> d# 5 rshift h# 6 and rshift dup>r \ mask in R
+    invert and r> COMM+2 c@ and or
+    swap c!
+;
+
+: main
+    begin
+        \ wait until command reg is nonzero
+        begin
+            COMM+2 c@
+        until
+        
+        \ 0 is X, 1 is Y
+        COMM+0 c@ COMM+1 c@ swab or
+        setpixel
+
+        \ tell host we're done
+        d# 0 COMM+2 c!
+    again
+;
+
+end-microcode

+ 17 - 0
showvoices.fs

@@ -0,0 +1,17 @@
+start-microcode showvoices
+
+\ continuously move sprites 0-63 to match amplitude of the
+\ 64 sound voices.
+
+: main
+    d# 0
+    begin
+        dup d# 4 * VOICES + d# 2 + c@   \ read voice amplitude
+        invert
+        over d# 4 * RAM_SPR + d# 2 + c! \ write as sprite Y coord
+        1- h# 3f and                    \ next voice
+    again
+;
+
+end-microcode
+

+ 33 - 0
soundbuffer.fs

@@ -0,0 +1,33 @@
+start-microcode soundbuffer
+
+\ Interface:
+\ COMM+0    sound read pointer
+\ 3F00-3FFF sound buffer
+
+\ This microprogram provides a simple sound sample buffer.
+\ It reads 8-bit samples from the buffer at 3F00-3FFF and
+\ writes them to the audio sample registers SAMPLE_L and
+\ SAMPLE_R.
+\ The current buffer read pointer is COMM+0.
+
+h# 3f00 constant BUFFER
+[ 125 50 * ] constant CYCLE \ one cycle of 8KHz in clocks
+
+: 1+    d# 1 + ;
+: -     invert 1+ + ;
+
+: main
+    d# 0        ( when )
+    begin
+        CLOCK c@ over -     \ positive means CLOCK has passed `when`
+        d# 0 < invert if
+            COMM+0 c@ dup
+            h# 3f00 + c@
+            dup SAMPLE_Lhi c! SAMPLE_Rhi c!
+            1+ COMM+0 c!
+            CYCLE +
+        then
+    again
+;
+
+end-microcode

+ 99 - 0
spectrum.fs

@@ -0,0 +1,99 @@
+start-microcode spectrum
+
+\ Interface:
+\ 4000-57FF Spectrum bitmap
+\ 5800-5AFF Spectrum attributes
+\ 7000 attribute lookup: 256 bytes.  64 colors of (paper, ink)
+\ 7100 pixel stretch, 16 bytes.
+
+: 1+    d# 1 + ;
+: 0=    d# 0 = ;
+: 4*    d# 4 * ;
+: 64mod h# 3f and ;
+
+: copy1 ( src dst -- src' dst' ) \ copy one byte
+    over c@
+    over c!
+    1+
+;fallthru
+: n1+  ( a b -- a+1 b )
+    swap 1+ swap ;
+
+\ copy attrs for line y
+\ dst is RAM_PAL or RAM_PAL+256
+
+: attrcopy ( y -- )
+    dup 4* h# 5800 + swap            ( src y )
+    h# 8 and d# 32 * RAM_PAL +       ( src dst ) 
+    begin
+        over c@ 64mod 4* h# 7000 + swap \ fetch and lookup attribute
+        copy1 copy1 d# 4 + copy1 copy1 nip
+        n1+
+        dup h# ff and 0=
+    until
+    drop drop
+;
+
+: stretch! ( dst a -- dst' ) \ expand 4 bit graphic a, write to dst
+    h# f and
+    h# 7100 + c@
+    over c! 1+
+    ;
+
+: byte ( src dst -- src' dst' )
+    over c@ swap    ( src a dst )
+                    
+    over d# 4 rshift stretch!
+    swap stretch!  ( src dst' )
+    swap h# 100 + swap      \ down 1 line in spectrum video memory
+;
+
+: byte4
+    byte byte byte byte ;
+
+: pixelcopy ( y -- y )
+    dup 64mod 4* h# 4000 +
+    over h# c0 and d# 32 * +    ( y src )
+    begin
+        dup
+        dup 64mod d# 16 * RAM_CHR +
+        byte4 byte4
+        drop drop
+        1+
+        dup h# 1f and 0=
+    until drop
+;
+
+\ Spectrum memory layout is a bit twisted
+\ line 0      4000, 4001, 4002
+\      1      4100, 4101
+\             ...
+\      8      4020
+\             ...
+\      56     40e0, ...             40ff
+\             ...
+\      63     47e0                  47ff
+\      64     4800
+\      65     4900
+\             ...
+\      191    57e0
+
+\ at line  0 can start work on 4020
+\ at line  8 can start work on 4040
+\ at line 16 can start work on 4060
+\         56                   4800
+\
+\ So in general, at line Y can start work on converting from:
+\ 4000 + (((Y+8) & 38) * 4) + (((y+8) & c0) * 32)
+
+: main
+    d# 0
+    begin
+        begin dup d# 48 + YLINE c@ = until
+        d# 8 + h# ff and
+        dup attrcopy
+        pixelcopy
+    again
+;
+
+end-microcode

+ 29 - 0
splitscreen.fs

@@ -0,0 +1,29 @@
+start-microcode splitscreen
+
+: 1+    d# 1 + ;
+: @     dupc@ swap 1+ c@ swab or ;
+
+: waitline ( u -- ) \ wait until raster is past u
+    begin
+        dup YLINE c@ =
+    until
+    drop
+;
+
+: loadscroll ( a -- ) \ load SCROLL_X,Y from a
+    dup c@ SCROLL_X c! 1+
+    dup c@ SCROLL_Xhi c! 1+
+    dup c@ SCROLL_Y c! 1+
+    c@ dup SCROLL_Yhi c!
+    d# 7 rshift SPR_DISABLE c!
+;
+
+: main
+    begin
+        COMM+4 @  waitline  COMM+6 loadscroll
+        COMM+10 @ waitline  COMM+12 loadscroll
+        d# 300 waitline     COMM+0 loadscroll
+    again
+;
+
+end-microcode

+ 13 - 0
spr512.fs

@@ -0,0 +1,13 @@
+start-microcode spr512
+
+: main
+    begin
+        d# 150
+        YLINE c@
+        <
+        SPR_PAGE c!
+    again
+;
+
+end-microcode
+

+ 42 - 0
testflash.fs

@@ -0,0 +1,42 @@
+start-microcode testflash
+
+: 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 swab 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 ;
+
+\ See Atmel AT45DB021D datasheet:
+\ http://www.atmel.com/dyn/resources/prod_documents/doc3638.pdf
+
+: main
+    spi-cold
+    spi-sel
+    h# d7 spi-xfer      \ flash read status command
+    spi-xfer            \ send junk, receive status
+    spi-unsel
+
+    COMM+0 c!           \ write status to COMM+0
+
+    begin again         
+;
+
+end-microcode

+ 69 - 0
wireframe.fs

@@ -0,0 +1,69 @@
+start-microcode wireframe
+
+\ See http://en.wikipedia.org/wiki/Bresenham's_line_algorithm
+
+COMM+0 constant X0
+COMM+1 constant Y0
+COMM+2 constant X1
+COMM+3 constant Y1
+COMM+4 constant steep
+COMM+5 constant deltax
+COMM+6 constant deltay
+COMM+7 constant ystep
+COMM+8 constant color
+
+: setpixel ( yx -- ) \ set pixel yx to color
+    dup>r
+    h# f and
+    r@ d# 4 rshift h# 0ff0 and or
+    r@ h# 30 and swab or
+    RAM_SPRIMG or ( addr )
+    dupc@ ( addr v )
+    color c@ r> d# 5 rshift h# 6 and rshift or
+    swap c!
+;
+
+: negate invert ;fallthru
+: 1+    d# 1 + ;
+: @     dupc@ swap 1+ c@ swab or ;
+: byte  h# ff and ;
+
+: bresenham
+    deltay c@ negate >r     \ keep -deltay on R stack for speed
+    X0 @                    \ load y0x0
+    deltax c@ d# 1 rshift   \ load deltax/1, is error
+
+                    ( y0x0 error )
+    begin
+        over byte X1 c@ xor
+    while
+        over
+        steep c@ if swab then
+        setpixel
+        r@ +                \ error -= deltay
+        dup d# 0 < if
+            deltax c@ +     \ error += deltax
+            ystep c@ swab 1+
+        else
+            d# 1
+        then
+        >r swap r> + swap   \ increment YX
+    repeat
+    r> drop
+;
+
+: main
+    begin
+        \ wait until command reg is nonzero
+        begin
+            ystep c@
+        until
+        
+        bresenham
+
+        \ tell host we're done
+        d# 0 ystep c!
+    again
+;
+
+end-microcode