commit 948b82b151cb5285592f942c475159199ed0349c
parent 1ac2f978f3114ee59d70785e5519499b718a9287
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 5 Jul 2023 22:44:34 -0400
cos: wordtbl
Diffstat:
3 files changed, 31 insertions(+), 3 deletions(-)
diff --git a/fs/cos/core.blk b/fs/cos/core.blk
@@ -1 +1 @@
-MASTER INDEX 001 Useful little words 010 RX/TX tools 020 Block editor 035 Memory Editor 040 AVR SPI programmer 045 Sega ROM signer 050 Virgil's workspace 060-199 unused 200 Cross compilation 210 Core words 230 BLK subsystem 235 RX/TX subsystem 237 Media Span subsystem 240 Grid subsystem 245 PS/2 keyboard subsystem 250 SD Card subsystem 260 Fonts 280-289 unused 290 Automated tests 300 Arch-specific content \ Useful little words. CRC16[] MOVE- '? CRC16[] [IF] \S [THEN] \ Compute CRC16 over a memory range : CRC16[] ( a u -- c ) >R >A 0 BEGIN AC@+ CRC16 NEXT ; : MOVE- ( a1 a2 u -- ) \ *A* MOVE starting from the end ?DUP IF >R OVER - ( a1 diff ) SWAP R@ + >A BEGIN ( diff ) A- A> OVER + AC@ SWAP C! NEXT DROP ELSE 2DROP THEN ; \ Useful little words. MEM>BLK BLK>MEM \ *A* Copy an area of memory into blocks. : MEM>BLK ( addr blkno blkcnt ) >R BEGIN ( a blk ) DUP BLK@ 1+ SWAP DUP BLK( $400 MOVE BLK!! $400 + SWAP NEXT DROP FLUSH ; \ *A* Copy subsequent blocks in an area of memory : BLK>MEM ( blkno blkcnt addr ) ROT> >R BEGIN ( a blk ) DUP BLK@ 1+ SWAP BLK( OVER $400 MOVE $400 + SWAP NEXT DROP ; \ Context. Allows multiple concurrent dictionaries. \ See doc/usage.txt 0 VALUE saveto \ where to save CURRENT in next switch : context DOER CURRENT , DOES> ( a -- ) saveto IF CURRENT TO saveto THEN ( a ) DUP TO saveto ( a ) @ CURRENT ! ; \ string manipulation. '? >s [IF] \S [THEN] 2 VALUES sa sl : >s ( sa sl -- ) TO sl TO sa ; : s> sa sl ; : cutr ( n -- ) sl -^ DUP 0< IF DROP 0 THEN TO sl ; : cutl ( n -- ) sl SWAP cutr sl - sa + TO sa ; : prefix? ( sa sl -- f ) DUP sl > IF 2DROP 0 EXIT THEN sa ROT> []= ; : suffix? ( sa sl -- f ) DUP sl > IF 2DROP 0 EXIT THEN sl OVER - ( sa sl off ) sa + ( sa sl sa2 ) SWAP []= ; \ Word table. See doc/wordtbl : WORDTBL ( n -- a ) CREATE HERE SWAP << ALLOT0 1 HERE C! ; : W+ ( a -- a+2? ) 1+ 1+ DUP @ IF DROP THEN ; : :W ( a -- a+2? ) HERE XTCOMP OVER ! W+ ; : 'W ( a -- a+2? ) ' OVER ! W+ ; : WEXEC ( tbl idx -- ) << + @ EXECUTE ; \ Pager. See doc/pager 4 VALUES ''EMIT ''KEY? chrcnt lncnt 20 VALUE PGSZ : realKEY BEGIN ''KEY? EXECUTE UNTIL ; : back ''EMIT 'EMIT ! ''KEY? 'KEY? ! ; : emit ( c -- ) chrcnt 1+ TO chrcnt DUP CR = chrcnt LNSZ = OR IF 0 TO chrcnt lncnt 1+ TO lncnt THEN ''EMIT EXECUTE lncnt PGSZ = IF 0 TO lncnt NL> ." Press q to quit, any key otherwise" NL> realKEY 'q' = IF back QUIT THEN THEN ; : key? back KEY? ; : page 'EMIT @ TO ''EMIT 'KEY? @ TO ''KEY? ['] emit 'EMIT ! ['] key? 'KEY? ! ; \ Flow words '? PC NOT [IF] ALIAS HERE PC [THEN] '? PC2A NOT [IF] : PC2A ; [THEN] ALIAS PC BEGIN, : LSET PC TO ; : BR PC - 2 - _bchk ; : FJR BEGIN, 1+ 0 ; : IFZ, FJR JRNZi, ; : IFNZ, FJR JRZi, ; : IFC, FJR JRNCi, ; : IFNC, FJR JRCi, ; \ warning: l is a PC value, not a mem addr! \ also, in 6502, JRi, is 3b instead of 2, hence the hack. : FMARK ( l -- ) PC2A DUP C@ IF ( hack ) 1+ THEN DUP HERE -^ 1- SWAP C! ; : THEN, FMARK ; : ELSE, FJR JRi, SWAP FMARK ; \ Communicate blocks with block server. See doc/blksrv. CREATE h16 '$' C, 4 ALLOT : RX>h16 ( -- n ) \ *A* h16 1+ >A 4 >R BEGIN RX< DUP EMIT SPC> AC!+ NEXT h16 5 PARSE NOT IF 0 THEN ; : csumchk ( c1 c2 ) = NOT IF ABORT" bad csum" THEN ; : blksrv< ( blkno -- ) \ *A* RX<< TX[ 'G' EMIT .X ]TX 0 ( csum ) BLK( >A 1024 >R BEGIN RX< DUP AC!+ + NEXT RX>h16 csumchk ; : blksrv> ( blkno -- ) \ *A* RX<< TX[ 'P' EMIT .X ]TX 0 ( csum ) BLK( >A 1024 >R BEGIN AC@+ DUP TX> + NEXT TX[ .X ]TX ; \ Remote shell. See doc/rxtx : RX<?? RX<? ?DUP NOT IF 100 TICKS RX<? THEN ; : _<< \ print everything available from RX<? BEGIN RX<?? IF EMIT ELSE EXIT THEN AGAIN ; : _<<1r RX< EMIT _<< ; : rsh BEGIN KEY? IF DUP EOT = IF DROP EXIT ELSE TX> THEN THEN _<< AGAIN ; \ rupload. See doc/rxtx : CR> CR EMIT ; : unpack DUP $f0 OR SWAP $0f OR ; : out unpack TX> TX> ; : out2 L|M out out ; : rdok \ read RX until after "ok" BEGIN RX< WS? NOT UNTIL _<<1r ; : rupload ( loca rema u -- ) TX[ ." : in KEY $f0 AND KEY $0f AND OR ;" CR> rdok ." : in2 in <<8 in OR ;" CR> rdok \ sig: chk -- chk, a and then u are KEYed in ." : _ in2 >A in2 >R BEGIN in TUCK + SWAP AC!+ NEXT ;" CR> rdok DUP ROT ( loca u u rema ) ." 0 _" CR> out2 out2 ]TX >R >A 0 BEGIN ( chk ) '.' EMIT AC@ out AC@+ + NEXT _<<1r TX[ ." .X FORGET in" CR> ]TX rdok .X ; \ XMODEM routines. See doc/rxtx : _<<s BEGIN RX<? IF DROP ELSE EXIT THEN AGAIN ; : _rx>mem1 ( addr -- f, Receive single packet, f=eot ) RX< 1 = NOT IF ( EOT ) $6 ( ACK ) TX> 1 EXIT THEN '.' EMIT RX< RX< 2DROP ( packet num ) >A 0 ( crc ) 128 >R BEGIN ( crc ) RX< DUP ( crc n n ) AC!+ ( crc n ) CRC16 NEXT RX< <<8 RX< OR ( sender's CRC ) = IF $6 ( ACK ) ELSE $15 'N' EMIT ( NACK ) THEN TX> 0 ; : RX>MEM ( addr --, Receive packets into addr until EOT ) _<<s 'C' TX> BEGIN ( a ) DUP _rx>mem1 SWAP 128 + SWAP UNTIL DROP ; : RX>BLK ( -- ) _<<s 'C' TX> BLK( BEGIN ( a ) DUP BLK) = IF DROP BLK( BLK! BLK> 1+ 'BLK> ! THEN DUP _rx>mem1 SWAP 128 + SWAP UNTIL 2DROP ; : _snd128 ( A:a -- A:a ) 0 128 >R BEGIN ( crc ) AC@+ DUP TX> ( crc n ) CRC16 ( crc ) NEXT L|M TX> TX> ; : _ack? 0 BEGIN DROP RX< DUP 'C' = NOT UNTIL DUP $06 ( ACK ) = IF DROP 1 ELSE $15 = NOT IF ABORT" out of sync" THEN 0 THEN ; : _waitC ." Waiting for C..." BEGIN RX<? IF 'C' = ELSE 0 THEN UNTIL ; : _mem>tx ( addr pktstart pktend -- ) OVER - >R SWAP >A BEGIN ( pkt ) 'P' EMIT DUP . SPC> $01 ( SOH ) TX> ( pkt ) 1+ ( pkt start at 1 ) DUP TX> $ff OVER - TX> ( pkt+1 ) _snd128 _ack? NOT IF LEAVE THEN NEXT DROP ; : MEM>TX ( a u -- Send u bytes to TX ) _waitC 128 /MOD SWAP IF 1+ THEN ( pktcnt ) 0 SWAP _mem>tx $4 ( EOT ) TX> RX< DROP ; : BLK>TX ( b1 b2 -- ) _waitC OVER - ( cnt ) >R BEGIN ( blk ) 'B' EMIT DUP . SPC> DUP BLK@ BLK( ( blk a ) OVER 8 * DUP 8 + ( a pktstart pktend ) _mem>tx 1+ NEXT $4 ( EOT ) TX> RX< DROP ; \ Block editor. see doc/ed. \ Cursor position in buffer. EDPOS/64 is line number 0 VALUE EDPOS CREATE IBUF LNSZ 1+ ALLOT0 \ counted string, first byte is len CREATE FBUF LNSZ 1+ ALLOT0 : L BLK> ." Block " DUP . NL> LIST ; : B BLK> 1- BLK@ L ; : N BLK> 1+ BLK@ L ; : IBUF+ IBUF 1+ ; : FBUF+ FBUF 1+ ; : ILEN IBUF C@ ; : FLEN FBUF C@ ; : EDPOS! TO EDPOS ; : EDPOS+! EDPOS + EDPOS! ; : 'pos ( pos -- a, addr of pos in memory ) BLK( + ; : 'EDPOS EDPOS 'pos ; \ Block editor, private helpers : _lpos ( ln -- a ) LNSZ * 'pos ; : _pln ( ln -- ) \ print line no ln with pos caret DUP _lpos DUP >A LNLEN 1 MAX >R BEGIN ( lno ) A> 'EDPOS = IF '^' EMIT THEN AC@+ SPC MAX EMIT NEXT ( lno ) SPC> 1+ . ; : _zline ( a -- ) LNSZ SPC FILL ; \ zero-out a line : _type ( buf -- ) \ *A* type into buf until end of INBUF IN<? ?DUP NOT IF DROP EXIT THEN OVER 1+ DUP _zline >A BEGIN ( buf c ) AC!+ IN<? ?DUP NOT UNTIL ( buf ) A> OVER - 1- ( buf len ) SWAP C! ; \ Block editor, T P U \ user-facing lines are 1-based : T 1- DUP LNSZ * EDPOS! _pln ; : P IBUF _type IBUF+ 'EDPOS LNSZ MOVE BLK!! ; : _mvln+ ( ln -- move ln 1 line down ) DUP 14 > IF DROP EXIT THEN _lpos DUP LNSZ + LNSZ MOVE ; : _U ( U without P, used in VE ) 15 EDPOS LNSZ / - ?DUP IF >R 14 BEGIN DUP _mvln+ 1- NEXT DROP THEN ; : U _U P ; \ Block editor, F i : _F ( F without _type and _pln. used in VE ) 'EDPOS 1+ BEGIN ( a ) FBUF+ C@ OVER BLK) OVER - ( a c a u ) [C]? DUP 0< IF 2DROP EXIT THEN ( a idx ) + ( a ) DUP FBUF+ FLEN []= IF BLK( - EDPOS! EXIT THEN 1+ AGAIN ; : F FBUF _type _F EDPOS LNSZ / _pln ; : _rbufsz ( size of linebuf to the right of curpos ) EDPOS LNSZ MOD LNSZ -^ ; : _I ( I without _pln and _type. used in VE ) _rbufsz ILEN OVER < IF ( rsize ) ILEN - ( chars-to-move ) 'EDPOS DUP ILEN + ROT ( a a+ilen ctm ) MOVE- ILEN THEN ( len-to-insert ) IBUF+ 'EDPOS ROT MOVE ( ilen ) BLK!! ; : I IBUF _type _I EDPOS LNSZ / _pln ; \ Block editor, X E Y : icpy ( n -- copy n chars from cursor to IBUF ) DUP IBUF C! IBUF+ _zline 'EDPOS IBUF+ ( n a buf ) ROT MOVE ; : _del ( n -- ) ?DUP NOT IF EXIT THEN _rbufsz MIN 'EDPOS 2DUP + ( n a1 a1+n ) SWAP _rbufsz MOVE ( n ) \ get to next line - n DUP EDPOS $ffc0 AND $40 + -^ 'pos ( n a ) SWAP SPC FILL BLK!! ; : _X ( n -- ) ?DUP NOT IF EXIT THEN _rbufsz MIN DUP icpy _del ; : X _X EDPOS LNSZ / _pln ; : _E FLEN _X ; : E FLEN X ; : Y FBUF IBUF LNSZ 1+ MOVE ; \ Visual text editor. VALUEs, lg? width pos@ mode! ... 3 VALUES PREVPOS xoff ACC LNSZ 3 + VALUE MAXW 10 VALUE MARKCNT CREATE MARKS MARKCNT << << ALLOT0 \ 4b: blk/edpos : nspcs ( pos n ) SPC FILLC ; : lg? COLS MAXW > ; : col- MAXW COLS MIN -^ ; : width lg? IF LNSZ ELSE COLS THEN ; : acc@ ACC 1 MAX ; : pos@ ( x y -- ) EDPOS LNSZ /MOD ; : num ( c -- ) \ c is in range 0-9 '0' - ACC 10 * + TO ACC ; : mode! ( c -- ) 4 col- CELL! ; \ VE, rfshln contents selblk pos! xoff? setpos : _ ( ln -- ) \ refresh line ln DUP _lpos xoff + SWAP 3 + COLS * lg? IF 3 + THEN width CELLS! ; : rfshln pos@ NIP _ ; \ refresh active line : contents 16 >R 0 BEGIN DUP _ 1+ NEXT DROP ; : selblk BLK@ contents ; : pos! ( newpos -- ) EDPOS TO PREVPOS DUP 0< IF DROP 0 THEN 1023 MIN EDPOS! ; : xoff? pos@ DROP ( x ) xoff ?DUP IF < IF 0 TO xoff contents THEN ELSE width >= IF LNSZ COLS - TO xoff contents THEN THEN ; : setpos ( -- ) pos@ 3 + ( header ) SWAP ( y x ) xoff - lg? IF 3 + ( gutter ) THEN SWAP AT-XY ; : 'mark ( -- a ) ACC MARKCNT MOD << << MARKS + ; \ VE, cmv buftype bufprint bufs : cmv ( n -- , char movement ) acc@ * EDPOS + pos! ; : buftype ( buf ln -- ) \ type into buf at ln 3 OVER AT-XY KEY DUP SPC < IF 2DROP DROP EXIT THEN ( b ln c ) SWAP COLS * 3 + 3 col- nspcs ( buf c ) IN( SWAP LNTYPE DROP BEGIN ( buf a ) KEY LNTYPE UNTIL IN( - ( buf len ) SWAP C!+ IN( SWAP LNSZ MOVE IN$ ; : _ ( buf sa sl pos ) DUP >R STYPEC ( buf ) C@+ ( buf sz ) R> 3 + STYPEC ; : bufs ( -- ) \ refresh I and F lines IBUF S" I: " COLS _ FBUF S" F: " COLS 2 * _ ; : insl _U EDPOS $3c0 AND DUP pos! 'pos _zline BLK!! contents ; \ VE cmds 31 VALUE cmdcnt CREATE cmdl ," G[]IFnNYEXChlkjHLg@!wWb&mtfROoD" cmdcnt WORDTBL cmds :W ( G ) ACC selblk ; :W ( [ ) BLK> acc@ - selblk ; :W ( ] ) BLK> acc@ + selblk ; : insert 'I' mode! IBUF 1 buftype _I bufs rfshln ; 'W insert ( I ) :W ( F ) 'F' mode! FBUF 2 buftype _F bufs setpos ; :W ( n ) _F setpos ; :W ( N ) EDPOS _F EDPOS = IF 0 EDPOS! acc@ >R BEGIN BLK> 1+ BLK@ _F EDPOS IF LEAVE THEN NEXT contents setpos THEN ; :W ( Y ) Y bufs ; :W ( E ) _E bufs rfshln ; :W ( X ) acc@ _X bufs rfshln ; :W ( C ) FLEN _del rfshln insert ; \ VE cmds :W ( h ) -1 cmv ; :W ( l ) 1 cmv ; :W ( k ) -64 cmv ; :W ( j ) 64 cmv ; : bol EDPOS $3c0 AND pos! ; 'W bol ( H ) :W ( L ) EDPOS DUP $3f OR 2DUP = IF 2DROP EXIT THEN SWAP BEGIN ( res p ) 1+ DUP 'pos C@ WS? NOT IF NIP DUP 1+ SWAP THEN DUP $3f AND $3f = UNTIL DROP pos! ; :W ( g ) ACC 1 MAX 1- 64 * pos! ; :W ( @ ) BLK> BLK( (blk@) 0 BLKDTY ! contents ; :W ( ! ) BLK> FLUSH 'BLK> ! ; \ VE cmds : C@- DUP 1- SWAP C@ ; : word>> BEGIN C@+ WS? UNTIL ; : ws>> BEGIN C@+ WS? NOT UNTIL ; : word<< BEGIN C@- WS? UNTIL ; : ws<< BEGIN C@- WS? NOT UNTIL ; : bpos! BLK( - pos! ; :W ( w ) 'EDPOS acc@ >R BEGIN word>> ws>> NEXT 1- bpos! ; :W ( W ) 'EDPOS acc@ >R BEGIN ws>> word>> NEXT 1- bpos! ; :W ( b ) 'EDPOS acc@ >R BEGIN 1- ws<< word<< NEXT 1+ 1+ bpos! ; :W ( & ) WIPE contents ; :W ( m ) BLK> 'mark ! EDPOS 'mark 1+ 1+ ! ; :W ( t ) 'mark 1+ 1+ @ pos! 'mark @ selblk ; \ VE cmds :W ( f ) EDPOS PREVPOS 2DUP = IF 2DROP EXIT THEN 2DUP > IF DUP pos! SWAP THEN ( p1 p2, p1 < p2 ) OVER - LNSZ MIN ( pos len ) DUP FBUF C! FBUF+ _zline SWAP 'pos FBUF+ ( len src dst ) ROT MOVE bufs ; :W ( R ) 'R' mode! BEGIN setpos KEY DUP BS? IF -1 EDPOS+! DROP 0 THEN DUP SPC >= IF DUP EMIT 'EDPOS C! 1 EDPOS+! BLK!! 0 THEN UNTIL ; 'W insl ( O ) :W ( o ) EDPOS $3c0 < IF EDPOS 64 + EDPOS! insl THEN ; :W ( D ) bol LNSZ icpy acc@ LNSZ * ( delsz ) BLK) 'EDPOS - MIN >R 'EDPOS R@ + 'EDPOS ( src dst ) BLK) OVER - MOVE BLK) R@ - R> SPC FILL BLK!! bufs contents ; \ VE final: status nums gutter handle VE : status 0 $20 nspcs 0 0 AT-XY ." BLK" SPC> BLK> . SPC> ACC . SPC> pos@ 1+ . ',' EMIT . xoff IF '>' EMIT THEN SPC> BLKDTY @ IF '*' EMIT THEN SPC mode! ; : nums 16 >R BEGIN R@ HERE FMTD R@ 2 + COLS * STYPEC NEXT ; : gutter lg? IF 19 >R BEGIN '|' R@ 1- COLS * MAXW + CELL! NEXT THEN ; : handle ( c -- f ) DUP '0' '9' =><= IF num 0 EXIT THEN DUP cmdl cmdcnt [C]? 1+ ?DUP IF 1- cmds SWAP WEXEC THEN 0 TO ACC 'q' = ; : VE BLK> 0< IF 0 BLK@ THEN CLRSCR 0 TO ACC 0 TO PREVPOS nums bufs contents gutter BEGIN xoff? status setpos KEY handle UNTIL 0 19 AT-XY ; \ Memory Editor. See doc/me CREATE CMD '#' C, 0 C, CREATE BUF '$' C, 4 ALLOT \ always hex \ POS is relative to ADDR 4 VALUES ADDR POS HALT? ASCII? 16 VALUE AWIDTH LINES 2 - VALUE AHEIGHT AHEIGHT AWIDTH * VALUE PAGE COLS 33 < [IF] 8 TO AWIDTH [THEN] : addr ADDR POS + ; CREATE _ ," 0123456789abcdef" : hex! ( c pos -- ) OVER 16 / _ + C@ OVER CELL! ( c pos ) 1+ SWAP $f AND _ + C@ SWAP CELL! ; : bottom 0 LINES 1- AT-XY ; \ Memory Editor, line rfshln contents showpos : line ( ln -- ) DUP AWIDTH * ADDR + >A 1+ COLS * ( pos ) ':' OVER CELL! A> <<8 >>8 OVER 1+ hex! 4 + ( pos+4 ) AWIDTH >> >R A> SWAP BEGIN ( a-old pos ) AC@+ ( a-old pos c ) OVER hex! ( a-old pos ) 1+ 1+ AC@+ OVER hex! 3 + ( a-old pos+5 ) NEXT SWAP >A AWIDTH >R BEGIN ( pos ) AC@+ DUP SPC - $5e > IF DROP '.' THEN OVER CELL! 1+ NEXT DROP ; : rfshln POS AWIDTH / line ; : contents LINES 2 - >R BEGIN R@ 1- line NEXT ; : showpos POS AWIDTH /MOD ( r q ) 1+ SWAP ( y r ) ASCII? IF AWIDTH >> 5 * + ELSE DUP 1 AND << SWAP >> 5 * + THEN 4 + ( y x ) SWAP AT-XY ; \ Memory Editor, addr! pos! status type typep : addr! $fff0 AND TO ADDR contents ; : pos! DUP 0< IF PAGE + THEN DUP PAGE >= IF PAGE - THEN TO POS showpos ; : status 0 COLS SPC FILLC 0 0 AT-XY ." A: " ADDR .X SPC> ." C: " POS .X SPC> ." S: " PSDUMP POS pos! ; : type ( cnt -- sa sl ) BUF 1+ >A >R BEGIN KEY DUP SPC < IF DROP LEAVE ELSE DUP EMIT AC!+ THEN NEXT BUF A> BUF - ; : typep ( cnt -- n? f ) type ( sa sl ) DUP IF PARSE ELSE NIP THEN ; \ Memory Editor, almost all actions : #] ADDR PAGE + addr! ; : #[ ADDR PAGE - addr! ; : #J ADDR $10 + addr! POS $10 - pos! ; : #K ADDR $10 - addr! POS $10 + pos! ; : #l POS 1+ pos! ; : #h POS 1- pos! ; : #j POS AWIDTH + pos! ; : #k POS AWIDTH - pos! ; : #m addr ; : #@ addr @ ; : #! addr ! contents ; : #g SCNT IF DUP ADDR - PAGE < IF ADDR - pos! ELSE DUP addr! $f AND pos! THEN THEN ; : #G bottom 4 typep IF #g THEN ; : #a ASCII? NOT TO ASCII? showpos ; : #f #@ #g ; : #e #m #f ; : _h SPC> showpos 2 typep ; : _a showpos KEY DUP SPC < IF DROP 0 ELSE DUP EMIT 1 THEN ; : #R BEGIN SPC> ASCII? IF _a ELSE _h THEN ( n? f ) IF addr C! rfshln #l 0 ELSE 1 THEN UNTIL rfshln ; \ Memory Editor, #q handle ME : #q 1 TO HALT? ; : handle ( c -- f ) CMD 1+ C! CMD 2 FIND IF EXECUTE THEN ; : ME 0 TO HALT? CLRSCR contents 0 pos! BEGIN status KEY handle HALT? UNTIL bottom ; \ AVR Programmer, B160-B163. doc/avr.txt \ page size in words, 64 is default on atmega328P 64 VALUE aspfpgsz 0 VALUE aspprevx : _x ( a -- b ) DUP TO aspprevx (spix) ; : _xc ( a -- b ) DUP (spix) ( a b ) DUP aspprevx = NOT IF ABORT" AVR err" THEN ( a b ) SWAP TO aspprevx ( b ) ; : _cmd ( b4 b3 b2 b1 -- r4 ) _xc DROP _xc DROP _xc DROP _x ; : asprdy ( -- ) BEGIN 0 0 0 $f0 _cmd 1 AND NOT UNTIL ; : asp$ ( spidevid -- ) ( RESET pulse ) DUP (spie) 0 (spie) (spie) ( wait >20ms ) 220 TICKS ( enable prog ) $ac (spix) DROP $53 _x DROP 0 _xc DROP 0 _x DROP ; : asperase 0 0 $80 $ac _cmd asprdy ; ( fuse access. read/write one byte at a time ) : aspfl@ ( -- lfuse ) 0 0 0 $50 _cmd ; : aspfh@ ( -- hfuse ) 0 0 $08 $58 _cmd ; : aspfe@ ( -- efuse ) 0 0 $00 $58 _cmd ; : aspfl! ( lfuse -- ) 0 $a0 $ac _cmd ; : aspfh! ( hfuse -- ) 0 $a8 $ac _cmd ; : aspfe! ( efuse -- ) 0 $a4 $ac _cmd ; : aspfb! ( n a --, write word n to flash buffer addr a ) SWAP L|M SWAP ( a hi lo ) ROT ( hi lo a ) DUP ROT ( hi a a lo ) SWAP ( hi a lo a ) 0 $40 ( hi a lo a 0 $40 ) _cmd DROP ( hi a ) 0 $48 _cmd DROP ; : aspfp! ( page --, write buffer to page ) 0 SWAP aspfpgsz * L|M ( 0 lsb msb ) $4c _cmd DROP asprdy ; : aspf@ ( page a -- n, read word from flash ) SWAP aspfpgsz * OR ( addr ) L|M ( lsb msb ) 2DUP 0 ROT> ( lsb msb 0 lsb msb ) $20 _cmd ( lsb msb low ) ROT> 0 ROT> ( low 0 lsb msb ) $28 _cmd <<8 OR ; : aspe@ ( addr -- byte, read from EEPROM ) 0 SWAP L|M SWAP ( 0 msb lsb ) $a0 ( 0 msb lsb $a0 ) _cmd ; : aspe! ( byte addr --, write to EEPROM ) L|M SWAP ( b msb lsb ) $c0 ( b msb lsb $c0 ) _cmd DROP asprdy ; ( Sega ROM signer. See doc/sega.txt ) : segasig ( addr size -- ) $2000 OVER LSHIFT ( a sz bytesz ) $10 - >R ( a sz ) SWAP >A 0 BEGIN ( sz csum ) AC@+ + NEXT ( sz csum ) 'T' AC!+ 'M' AC!+ 'R' AC!+ SPC AC!+ 'S' AC!+ 'E' AC!+ 'G' AC!+ 'A' AC!+ 0 AC!+ 0 AC!+ ( sum's LSB ) DUP AC!+ ( MSB ) >>8 AC!+ ( sz ) 0 AC!+ 0 AC!+ 0 AC!+ $4a + AC!+ ; CREATE MSPAN_DISK 0 C, CREATE (msdsks) 100 C, 100 C, 180 C, 0 C, : _ ( dsk -- ) DUP MSPAN_DISK C! S" Need disk " STYPE . SPC> ; : prompt _ KEY DROP ; : dskchk ( blk -- newblk ) A>R (msdsks) >A BEGIN AC@+ - DUP 0< AC@ NOT OR UNTIL A- AC@ + ( newblk ) A> (msdsks) - ( newblk dsk ) DUP MSPAN_DISK C@ = NOT IF prompt ELSE DROP THEN ( blk ) R>A ; \ utility to quickly examine freshly written asm words 0 VALUE mark : see mark >A HERE mark - >R BEGIN AC@+ .x SPC> NEXT mark 'HERE ! ; \ HERE TO mark \ Cross compilation program, generic part. See doc/cross 0 VALUE BIN( \ binary start in target's addr 0 VALUE XORG \ binary start address in host's addr 0 VALUE BIGEND? \ is target big-endian? 3 VALUES L1 L2 L3 : PC HERE XORG - BIN( + ; : PC2A ( pc -- a ) HERE PC - ( org ) + ; : XSTART ( bin( -- ) TO BIN( HERE TO XORG ; : OALLOT ( oa -- ) XORG + HERE - ALLOT0 ; : |T L|M BIGEND? NOT IF SWAP THEN ; : T! ( n a -- ) SWAP |T ROT C!+ C! ; : T, ( n -- ) |T C, C, ; : T@ C@+ SWAP C@ BIGEND? IF SWAP THEN <<8 OR ; : XCOMPC 201 205 LOADR ; : FONTC 262 263 LOADR ; \ Cross compilation program. COS-specific. See doc/cross : COREL 210 224 LOADR ; : COREH 225 229 LOADR ; : BLKSUB 230 234 LOADR ; : GRIDSUB 240 241 LOADR ; : PS2SUB 246 248 LOADR ; : RXTXSUB 235 LOAD ; : MSPANSUB 237 LOAD ; : SDCSUB 250 258 LOADR ; '? HERESTART NOT [IF] 0 VALUE HERESTART [THEN] 0 VALUE XCURRENT \ CURRENT in target system, in target's addr 8 VALUES lblnext lblcell lbldoes lblxt lblval lblhere lblmain lblboot '? 'A NOT [IF] SYSVARS $06 + VALUE 'A [THEN] '? 'N NOT [IF] SYSVARS $08 + VALUE 'N [THEN] 6 VALUES (n)* (b)* (br)* (?br)* EXIT* (next)* CREATE '~ 2 ALLOT \ Cross compilation program : _xoff ( a -- a ) XORG BIN( - ; : _wl ( w -- len ) 1- C@ $7f AND ; : _ws ( w len -- sa ) - 3 - ; : _xfind ( sa sl -- w? f ) >R >A XCURRENT BEGIN ( w R:sl ) _xoff + DUP _wl R@ = IF ( w ) DUP R@ _ws A> R@ ( w a1 a2 u ) []= IF ( w ) R~ 1 EXIT THEN THEN 3 - ( prev field ) T@ ?DUP NOT UNTIL R~ 0 ( not found ) ; : XFIND ( sa sl -- w ) _xfind NOT IF (wnf) THEN _xoff - ; : X' WORD XFIND ; : '? WORD _xfind DUP IF NIP THEN ; : ENTRY WORD TUCK MOVE, XCURRENT T, C, HERE _xoff - TO XCURRENT ; \ Cross compilation program : ;CODE lblnext JMPi, ; : ALIAS X' ENTRY JMPi, ; : *ALIAS ENTRY JMP(i), ; : CONSTANT ENTRY i>, ;CODE ; : CONSTS >R BEGIN RUN1 CONSTANT NEXT ; : CONSTS+ ( off n -- ) >R BEGIN RUN1 OVER + CONSTANT NEXT DROP ; : *VALUE ENTRY (i)>, ;CODE ; : CREATE ENTRY lblcell CALLi, ; : _ ( lbl str -- ) CURWORD S= IF XCURRENT SWAP TO EXECUTE ELSE DROP THEN ; : CODE ENTRY ['] EXIT* S" EXIT" _ ['] (b)* S" (b)" _ ['] (n)* S" (n)" _ ['] (br)* S" (br)" _ ['] (?br)* S" (?br)" _ ['] (next)* S" (next)" _ ; : LITN DUP $ff > IF (n)* T, T, ELSE (b)* T, C, THEN ; \ Cross compilation program : imm? ( w -- f ) 1- C@ $80 AND ; : compile BEGIN WORD S" ;" S= IF EXIT* T, EXIT THEN CURWORD PARSE IF LITN ELSE CURWORD _xfind IF ( w ) DUP imm? IF ABORT" immed!" THEN _xoff - T, ELSE CURWORD FIND IF ( w ) DUP imm? IF EXECUTE ELSE (wnf) THEN ELSE (wnf) THEN THEN ( _xfind ) THEN ( PARSE ) AGAIN ; : :~ HERE _xoff - '~ ! lblxt CALLi, compile ; : ~ '~ @ T, ; IMMEDIATE : _ CODE lblxt CALLi, compile ; \ : can't have its name now : ?: '? IF S" ;" WAITW ELSE CURWORD WORD! _ THEN ; : ~DOER ENTRY lbldoes CALLi, [COMPILE] ~ ; \ Cross compilation program : XWRAP COREH XCURRENT lblhere PC2A T! HERESTART ?DUP NOT IF PC THEN lblhere PC2A 1+ 1+ T! ; : ['] WORD XFIND LITN ; IMMEDIATE : COMPILE [COMPILE] ['] S" ," XFIND T, ; IMMEDIATE : IF (?br)* T, HERE 1 ALLOT ; IMMEDIATE : ELSE (br)* T, 1 ALLOT [COMPILE] THEN HERE 1- ; IMMEDIATE : AGAIN (br)* T, HERE - C, ; IMMEDIATE : UNTIL (?br)* T, HERE - C, ; IMMEDIATE : NEXT (next)* T, HERE - C, ; IMMEDIATE : S" (br)* T, HERE 1 ALLOT HERE ," TUCK HERE -^ SWAP [COMPILE] THEN SWAP _xoff - LITN LITN ; IMMEDIATE : [COMPILE] WORD XFIND T, ; IMMEDIATE : IMMEDIATE XCURRENT _xoff + 1- DUP C@ $80 OR SWAP C! ; ':' ' _ 4 - C! \ give : its real name now 0 XSTART \ Core Forth words. See doc/cross. SYSVARS SYSVARS 12 CONSTS+ $00 IOERR $02 'CURRENT $04 'HERE $0a NL $0c LN< $0e 'EMIT $10 'KEY? $12 'CURWORD $16 '(wnf) $1c 'IN( $1e 'IN> $20 INBUF SYSVARS $02 + *VALUE CURRENT SYSVARS $04 + *VALUE HERE SYSVARS $0e + *ALIAS EMIT SYSVARS $10 + *ALIAS KEY? SYSVARS $1c + *VALUE IN( SYSVARS $1e + *VALUE IN> $40 CONSTANT LNSZ CODE NOOP ;CODE \ Core words, basic arithmetic and stack management ?: = - NOT ; ?: > SWAP < ; ?: 0< $7fff > ; ?: 0>= $8000 < ; ?: >= < NOT ; ?: <= > NOT ; ?: 1+ 1 + ; ?: 1- 1 - ; ?: 2DROP DROP DROP ; ?: 2DUP OVER OVER ; ?: NIP SWAP DROP ; ?: TUCK SWAP OVER ; ?: ROT> ROT ROT ; ?: =><= ( n l h -- f ) OVER - ROT> ( h n l ) - >= ; : / /MOD NIP ; : MOD /MOD DROP ; ?: <> ( n n -- l h ) 2DUP > IF SWAP THEN ; ?: MIN <> DROP ; ?: MAX <> NIP ; ?: -^ SWAP - ; \ Core words, bit shifting, A register, LEAVE VAL L|M +! ?: << 2 * ; ?: >> 2 / ; ?: <<8 $100 * ; ?: >>8 $100 / ; ?: RSHIFT ?DUP IF >R BEGIN >> NEXT THEN ; ?: LSHIFT ?DUP IF >R BEGIN << NEXT THEN ; ?: L|M DUP <<8 >>8 SWAP >>8 ; ?: +! ( n a -- ) TUCK @ + SWAP ! ; ?: A> [ 'A LITN ] @ ; ?: >A [ 'A LITN ] ! ; ?: A>R R> A> >R >R ; ?: R>A R> R> >A >R ; ?: A+ 1 [ 'A LITN ] +! ; ?: A- -1 [ 'A LITN ] +! ; ?: AC@ A> C@ ; ?: AC! A> C! ; : AC@+ AC@ A+ ; : AC!+ AC! A+ ; : LEAVE R> R~ 1 >R >R ; ?: TO 1 [ SYSVARS $18 + LITN ] C! ; \ Core words, C@+ ALLOT FILL IMMEDIATE , L, M, MOVE MOVE, .. ?: C@+ DUP 1+ SWAP C@ ; ?: C!+ TUCK C! 1+ ; : ALLOT 'HERE +! ; ?: FILL ( a u b -- ) \ *A* ROT> >R >A BEGIN DUP AC!+ NEXT DROP ; : ALLOT0 ( u -- ) HERE OVER 0 FILL ALLOT ; : IMMEDIATE CURRENT 1- DUP C@ $80 OR SWAP C! ; : , HERE ! 2 ALLOT ; : C, HERE C! 1 ALLOT ; : L, DUP C, >>8 C, ; : M, DUP >>8 C, C, ; ?: MOVE ( src dst u -- ) ?DUP IF >R >A BEGIN ( src ) C@+ AC!+ NEXT DROP THEN ; : MOVE, ( a u -- ) HERE OVER ALLOT SWAP MOVE ; \ Core words, [C]? CRC16 []= JMPi! CALLi! ?: JMPi! [ X' NOOP PC2A C@ ( jmp op ) LITN ] SWAP C!+ ! 3 ; ?: CALLi! [ X' MOVE, PC2A C@ ( call op ) LITN ] SWAP C!+ ! 3 ; ?: [C]? ( c a u -- i ) \ Guards A ?DUP NOT IF 2DROP -1 EXIT THEN A>R OVER >R >R >A ( c ) BEGIN DUP AC@+ = IF LEAVE THEN NEXT ( c ) A- AC@ = IF A> R> - ( i ) ELSE R~ -1 THEN R>A ; ?: []= ( a1 a2 u -- f ) \ Guards A ?DUP NOT IF 2DROP 1 EXIT THEN A>R >R >A ( a1 ) BEGIN AC@+ OVER C@ = NOT IF R~ R>A DROP 0 EXIT THEN 1+ NEXT DROP R>A 1 ; ?: CRC16 ( c n -- c ) <<8 XOR 8 >R BEGIN ( c ) DUP 0< IF << $1021 XOR ELSE << THEN NEXT ; \ Core words, STYPE SPC> NL> STACK? LITN : STYPE >R >A BEGIN AC@+ EMIT NEXT ; 5 CONSTS $04 EOT $08 BS $0a LF $0d CR $20 SPC : SPC> SPC EMIT ; : NL> NL @ L|M ?DUP IF EMIT THEN EMIT ; : STACK? SCNT 0< IF S" stack underflow" STYPE ABORT THEN ; : LITN DUP >>8 IF COMPILE (n) , ELSE COMPILE (b) C, THEN ; \ Core words, number formatting : FMTD ( n a -- sa sl ) \ *A* 6 + >A A>R DUP >R DUP 0< IF 0 -^ THEN BEGIN ( n ) 10 /MOD ( d q ) A- SWAP '0' + AC! ?DUP NOT UNTIL R> 0< IF A- '-' AC! THEN R> A> TUCK - ; PC TO L1 ," 0123456789abcdef" :~ ( n a 'len -- sa sl ) \ *A* C@ DUP >R DUP >R + >A BEGIN ( n ) 16 /MOD ( d q ) A- SWAP [ L1 LITN ] + C@ AC! NEXT DROP A> R> ; ~DOER FMTx 2 C, ~DOER FMTX 4 C, :~ ( n 'w -- sa sl ) @ A>R HERE SWAP EXECUTE STYPE R>A ; ~DOER . X' FMTD T, ~DOER .x X' FMTx T, ~DOER .X X' FMTX T, \ Core words, literal parsing :~ ( sl -- n? f ) \ parse unsigned decimal >R 0 BEGIN ( r ) 10 * AC@+ ( r c ) '0' - DUP 9 > IF 2DROP R~ 0 EXIT THEN + NEXT ( r ) 1 ; : PARSE ( sa sl -- n? f ) \ *A* OVER C@ ''' = IF ( sa sl ) 3 = IF 1+ DUP 1+ C@ ''' = IF C@ 1 EXIT THEN THEN DROP 0 EXIT THEN ( sa sl ) OVER C@ '$' = IF ( sa sl ) 1- >R 1+ >A 0 BEGIN ( r ) 16 * AC@+ ( r c ) $20 OR [ L1 LITN ] ( B216 ) $10 [C]? DUP 0< IF 2DROP R~ 0 EXIT THEN + NEXT ( r ) 1 EXIT THEN SWAP >A DUP 1 > AC@ '-' = AND IF ( sl ) A+ 1- ~ IF 0 -^ 1 ELSE 0 THEN ELSE ~ THEN ; \ Core words, input buffer : KEY BEGIN KEY? UNTIL ; : IN) IN( LNSZ + ; PC BS C, $7f ( DEL ) C, : BS? [ ( PC ) LITN ] 2 [C]? 0>= ; : WS? SPC <= ; \ type c into ptr inside INBUF. f=true if typing should stop : LNTYPE ( ptr c -- ptr+-1 f ) DUP BS? IF ( ptr c ) DROP DUP IN( > IF 1- BS EMIT THEN SPC> BS EMIT 0 ELSE ( ptr c ) \ non-BS DUP SPC < IF DROP DUP IN) OVER - 0 FILL 1 ELSE TUCK EMIT C!+ DUP IN) = THEN THEN ; \ Core words, input buffer, ," : RDLN ( -- ) \ Read 1 line in IN( S" ok" STYPE NL> IN( BEGIN KEY LNTYPE UNTIL DROP NL> ; : IN<? ( -- c-or-0 ) IN> IN) < IF IN> C@+ SWAP 'IN> ! ELSE 0 THEN ; : IN< ( -- c ) IN<? ?DUP NOT IF LN< @ EXECUTE IN( 'IN> ! SPC THEN ; : IN$ ['] RDLN LN< ! INBUF 'IN( ! IN) 'IN> ! ; : ," BEGIN IN< DUP '"' = IF DROP EXIT THEN C, AGAIN ; \ Core words, WORD parsing : TOWORD ( -- ) BEGIN IN< WS? NOT UNTIL ; : CURWORD ( -- sa sl ) 'CURWORD 1+ @ 'CURWORD C@ ; :~ ( f sa sl -- ) 'CURWORD C!+ TUCK ! 1+ 1+ C! ; : WORD ( -- sa sl ) 'CURWORD 3 + C@ IF CURWORD ELSE TOWORD IN> 1- 0 ( sa sl ) BEGIN 1+ IN<? WS? UNTIL THEN ( sa sl ) 2DUP 0 ROT> ~ ; : WORD! 1 ROT> ~ ; \ Core words, FIND (wnf) RUN1 INTERPRET nC, ?: FIND ( sa sl -- w? f ) \ Guards A A>R >R >A CURRENT BEGIN ( w R:sl ) DUP 1- C@ $7f AND ( wlen ) R@ = IF ( w ) DUP R@ - 3 - A> R@ ( w a1 a2 u ) []= IF ( w ) R~ 1 R>A EXIT THEN THEN 3 - ( prev field ) @ ?DUP NOT UNTIL R~ 0 R>A ( not found ) ; : (wnf) CURWORD STYPE S" word not found" STYPE ABORT ; : RUN1 ( -- ) \ interpret next word WORD PARSE NOT IF CURWORD FIND NOT IF '(wnf) @ THEN EXECUTE STACK? THEN ; : INTERPRET BEGIN RUN1 AGAIN ; : nC, ( n -- ) >R BEGIN RUN1 C, NEXT ; \ Core words, CODE '? ' TO FORGET : CODE WORD TUCK MOVE, ( len ) CURRENT , C, \ write prev value and size HERE 'CURRENT ! ; : '? WORD FIND DUP IF NIP THEN ; : ' WORD FIND NOT IF (wnf) THEN ; : FORGET ' DUP ( w w ) \ HERE must be at the end of prev's word, that is, at the \ beginning of w. DUP 1- C@ ( len ) $7f AND ( rm IMMEDIATE ) 3 + ( fixed header len ) - 'HERE ! ( w ) ( get prev addr ) 3 - @ 'CURRENT ! ; \ Core words, S= WAITW [IF] _bchk : S= ( sa1 sl1 sa2 sl2 -- f ) ROT OVER = IF ( same len, s2 s1 l ) []= ELSE DROP 2DROP 0 THEN ; : WAITW ( sa sl -- ) BEGIN 2DUP WORD S= UNTIL 2DROP ; : [IF] NOT IF S" [THEN]" WAITW THEN ; ALIAS NOOP [THEN] : _bchk DUP $80 + $ff > IF S" br ovfl" STYPE ABORT THEN ; \ Core words, DUMP .S : DUMP ( n a -- ) \ *A* >A 8 /MOD SWAP IF 1+ THEN >R BEGIN ':' EMIT A> DUP .x SPC> ( a ) 4 >R BEGIN AC@+ .x AC@+ .x SPC> NEXT ( a ) >A 8 >R BEGIN AC@+ DUP SPC - $5e > IF DROP '.' THEN EMIT NEXT NL> NEXT ; : PSDUMP SCNT NOT IF EXIT THEN SCNT >A BEGIN DUP .X SPC> >R SCNT NOT UNTIL BEGIN R> SCNT A> = UNTIL ; : .S ( -- ) S" SP " STYPE SCNT .x SPC> S" RS " STYPE RCNT .x SPC> S" -- " STYPE STACK? PSDUMP ; \ Core high, CREATE DOER DOES> CODE ALIAS VALUE : ;CODE [ lblnext LITN ] HERE JMPi! ALLOT ; : CREATE CODE [ lblcell LITN ] HERE CALLi! ALLOT ; : DOER CODE [ lbldoes LITN ] HERE CALLi! 1+ 1+ ALLOT ; : _ R> CURRENT 3 + ! ; \ Popping RS makes us EXIT from parent : DOES> COMPILE _ [ lblxt LITN ] HERE CALLi! ALLOT ; IMMEDIATE : ALIAS ' CODE HERE JMPi! ALLOT ; : VALUE CODE [ lblval LITN ] HERE CALLi! ALLOT , ; : VALUES >R BEGIN 0 VALUE NEXT ; : CONSTS >R BEGIN RUN1 VALUE NEXT ; \ Core high, BOOT \ :~ IN$ INTERPRET BYE ; \ '~ @ lblmain PC2A T! \ set jump in QUIT \ PC TO lblhere 4 ALLOT \ CURRENT, HERESTART \ : BOOT [ lblhere LITN ] 'CURRENT 4 MOVE \ ['] (emit) 'EMIT ! ['] (key?) 'KEY? ! ['] (wnf) '(wnf) ! \ 0 'CURWORD 3 + C! \ 0 IOERR ! $0d0a ( CR/LF ) NL ! \ 0 [ SYSVARS $18 ( TO? ) + LITN ] C! \ INIT S" Collapse OS" STYPE ABORT ; : boot S" Collapse OS" stype abort ; \ XCURRENT lblboot PC2A T! \ initial jump to BOOT \ Core high, : : XTCOMP [ lblxt LITN ] HERE CALLi! ALLOT BEGIN WORD S" ;" S= IF COMPILE EXIT EXIT THEN CURWORD PARSE IF LITN ELSE CURWORD FIND IF DUP 1- C@ $80 AND ( imm? ) IF EXECUTE ELSE , THEN ELSE '(wnf) @ EXECUTE THEN THEN AGAIN ; : : CODE XTCOMP ; \ Core high, IF..ELSE..THEN ( \ : IF ( -- a | a: br cell addr ) COMPILE (?br) HERE 1 ALLOT ( br cell allot ) ; IMMEDIATE : THEN ( a -- | a: br cell addr ) DUP HERE -^ _bchk SWAP ( a-H a ) C! ; IMMEDIATE : ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell ) COMPILE (br) 1 ALLOT [COMPILE] THEN HERE 1- ( push a. 1- for allot offset ) ; IMMEDIATE : ( S" )" WAITW ; IMMEDIATE : \ IN) 'IN> ! ; IMMEDIATE : S" COMPILE (br) HERE 1 ALLOT HERE ," TUCK HERE -^ SWAP [COMPILE] THEN SWAP LITN LITN ; IMMEDIATE \ Core high, .", ABORT", BEGIN..AGAIN..UNTIL, many others. : ." [COMPILE] S" COMPILE STYPE ; IMMEDIATE : ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE : BEGIN HERE ; IMMEDIATE : AGAIN COMPILE (br) HERE - _bchk C, ; IMMEDIATE : UNTIL COMPILE (?br) HERE - _bchk C, ; IMMEDIATE : NEXT COMPILE (next) HERE - _bchk C, ; IMMEDIATE : [ INTERPRET ; IMMEDIATE : ] R~ R~ ; \ INTERPRET+RUN1 : COMPILE ' LITN ['] , , ; IMMEDIATE : [COMPILE] ' , ; IMMEDIATE : ['] ' LITN ; IMMEDIATE \ BLK subsystem. See doc/blk BLK_MEM CONSTANT BLK( \ $400 + "\S " BLK_MEM $400 + CONSTANT BLK) \ Current blk pointer -1 means "invalid" BLK_MEM $403 + DUP CONSTANT 'BLK> *VALUE BLK> \ Whether buffer is dirty BLK_MEM $405 + CONSTANT BLKDTY BLK_MEM $407 + CONSTANT BLKIN> : BLK$ 0 BLKDTY ! -1 'BLK> ! S" \S " BLK) SWAP MOVE ; : BLK! ( -- ) BLK> BLK( (blk!) 0 BLKDTY ! ; : FLUSH BLKDTY @ IF BLK! THEN -1 'BLK> ! ; : BLK@ ( n -- ) DUP BLK> = IF DROP EXIT THEN FLUSH DUP 'BLK> ! BLK( (blk@) ; : BLK!! 1 BLKDTY ! ; : WIPE BLK( 1024 SPC FILL BLK!! ; : COPY ( src dst -- ) FLUSH SWAP BLK@ 'BLK> ! BLK! ; : LNLEN ( a -- len ) \ len based on last visible char in line 1- LNSZ >R BEGIN DUP R@ + C@ SPC > IF DROP R> EXIT THEN NEXT DROP 0 ; : EMITLN ( a -- ) \ emit LNSZ chars from a or stop at CR DUP LNLEN ?DUP IF >R >A BEGIN AC@+ EMIT NEXT ELSE DROP THEN NL> ; : LIST ( n -- ) \ print contents of BLK n BLK@ 16 >R 0 BEGIN ( n ) DUP 1+ DUP 10 < IF SPC> THEN . SPC> DUP LNSZ * BLK( + EMITLN 1+ NEXT DROP ; : INDEX ( b1 b2 -- ) \ print first line of blocks b1 through b2 OVER - 1+ >R BEGIN DUP . SPC> DUP BLK@ BLK( EMITLN 1+ NEXT DROP ; : \S BLK) 'IN( ! IN( 'IN> ! ; :~ ( -- ) IN) 'IN( ! ; : LOAD IN> BLKIN> ! [ '~ @ LITN ] LN< ! BLK@ BLK( 'IN( ! IN( 'IN> ! BEGIN RUN1 IN( BLK) = UNTIL IN$ BLKIN> @ 'IN> ! ; \ >R R> around LOAD is to avoid bad blocks messing PS up : LOADR OVER - 1+ >R BEGIN DUP . SPC> DUP >R LOAD R> 1+ NEXT DROP ; \ Application loader, to include in boot binary : ED 1 LOAD ( MOVE- ) 20 24 LOADR ; : VE 5 LOAD ( wordtbl ) ED 25 32 LOADR ; : ME 35 39 LOADR ; : ARCHM 301 LOAD ; : RXTX 10 15 LOADR ; : XCOMP 200 LOAD ; \ RX/TX subsystem. See doc/rxtx RXTX_MEM CONSTANT _emit RXTX_MEM 2 + CONSTANT _key : RX< BEGIN RX<? UNTIL ; : RX<< 0 BEGIN DROP RX<? NOT UNTIL ; : TX[ 'EMIT @ _emit ! ['] TX> 'EMIT ! ; : ]TX _emit @ 'EMIT ! ; : RX[ 'KEY? @ _key ! ['] RX<? 'KEY? ! ; : ]RX _key @ 'KEY? ! ; \ Media Spanning subsystem. see doc/mspan MSPAN_MEM CONSTANT MSPAN_DISK ?: DRVSEL ( drv -- ) DROP ; : prompt ( dsk -- ) DUP MSPAN_DISK C! S" Need disk " STYPE . SPC> KEY '0' - DUP 10 < IF DRVSEL ELSE DROP THEN ; : MSPAN$ 0 MSPAN_DISK C! ; : dskchk ( blk -- newblk ) A>R (msdsks) >A BEGIN AC@+ - DUP 0< AC@ NOT OR UNTIL A- AC@ + ( newblk ) A> (msdsks) - ( newblk dsk ) DUP MSPAN_DISK C@ = NOT IF prompt ELSE DROP THEN ( blk ) R>A ; :~ ( blk dest 'w -- ) ROT dskchk ROT> @ EXECUTE ; ~DOER (blk@) X' (ms@) T, ~DOER (blk!) X' (ms!) T, \ Grid subsystem. See doc/grid. GRID_MEM DUP CONSTANT 'XYPOS *VALUE XYPOS ?: CURSOR! 2DROP ; : XYPOS! COLS LINES * MOD DUP XYPOS CURSOR! 'XYPOS ! ; : AT-XY ( x y -- ) COLS * + XYPOS! ; ?: NEWLN ( oldln -- newln ) 1+ LINES MOD DUP COLS * ( pos ) COLS >R BEGIN SPC OVER CELL! 1+ NEXT DROP ; ?: CELLS! ( a pos u -- ) ?DUP IF >R SWAP >A BEGIN ( pos ) AC@+ OVER CELL! 1+ NEXT ELSE DROP THEN DROP ; : STYPEC ( sa sl pos -- ) SWAP CELLS! ; ?: FILLC ( pos n c ) SWAP >R SWAP BEGIN ( b pos ) 2DUP CELL! 1+ NEXT 2DROP ; : CLRSCR 0 COLS LINES * SPC FILLC 0 XYPOS! ; :~ ( line feed ) XYPOS COLS / NEWLN COLS * XYPOS! ; ?: (emit) DUP BS? IF DROP SPC XYPOS TUCK CELL! ( pos ) 1- XYPOS! EXIT THEN DUP CR = IF DROP SPC XYPOS CELL! ~ EXIT THEN DUP SPC < IF DROP EXIT THEN XYPOS CELL! XYPOS 1+ DUP COLS MOD IF XYPOS! ELSE DROP ~ THEN ; : GRID$ 0 'XYPOS ! ; PS/2 keyboard subsystem Provides (key?) from a driver providing the PS/2 protocol. That is, for a driver taking care of providing all key codes emanat- ing from a PS/2 keyboard, this subsystem takes care of mapping those keystrokes to ASCII characters. This code is designed to be cross-compiled and loaded with drivers. Requires PS2_MEM to be defined. Load range: 246-249 : PS2_SHIFT [ PS2_MEM LITN ] ; : PS2$ 0 PS2_SHIFT C! ; \ A list of the values associated with the $80 possible scan \ codes of the set 2 of the PS/2 keyboard specs. 0 means no \ value. That value is a character that can be read in (key?) \ No make code in the PS/2 set 2 reaches $80. \ TODO: I don't know why, but the key 2 is sent as $1f by 2 of \ my keyboards. Is it a timing problem on the ATtiny? CREATE PS2_CODES $80 nC, 0 0 0 0 0 0 0 0 0 0 0 0 0 9 '`' 0 0 0 0 0 0 'q' '1' 0 0 0 'z' 's' 'a' 'w' '2' '2' 0 'c' 'x' 'd' 'e' '4' '3' 0 0 32 'v' 'f' 't' 'r' '5' 0 0 'n' 'b' 'h' 'g' 'y' '6' 0 0 0 'm' 'j' 'u' '7' '8' 0 0 ',' 'k' 'i' 'o' '0' '9' 0 0 '.' '/' 'l' ';' 'p' '-' 0 0 0 ''' 0 '[' '=' 0 0 0 0 13 ']' 0 '\' 0 0 0 0 0 0 0 0 8 0 0 '1' 0 '4' '7' 0 0 0 '0' '.' '2' '5' '6' '8' 27 0 0 0 '3' 0 0 '9' 0 0 ( Same values, but shifted ) $80 nC, 0 0 0 0 0 0 0 0 0 0 0 0 0 9 '~' 0 0 0 0 0 0 'Q' '!' 0 0 0 'Z' 'S' 'A' 'W' '@' '@' 0 'C' 'X' 'D' 'E' '$' '#' 0 0 32 'V' 'F' 'T' 'R' '%' 0 0 'N' 'B' 'H' 'G' 'Y' '^' 0 0 0 'M' 'J' 'U' '&' '*' 0 0 '<' 'K' 'I' 'O' ')' '(' 0 0 '>' '?' 'L' ':' 'P' '_' 0 0 0 '"' 0 '{' '+' 0 0 0 0 13 '}' 0 '|' 0 0 0 0 0 0 0 0 8 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 27 0 0 0 0 0 0 0 0 0 : _shift? ( kc -- f ) DUP $12 = SWAP $59 = OR ; : (key?) ( -- c? f ) (ps2kc) DUP NOT IF EXIT THEN ( kc ) DUP $e0 ( extended ) = IF ( ignore ) DROP 0 EXIT THEN DUP $f0 ( break ) = IF DROP ( ) ( get next kc and see if it's a shift ) BEGIN (ps2kc) ?DUP UNTIL ( kc ) _shift? IF ( drop shift ) 0 PS2_SHIFT C! THEN ( whether we had a shift or not, we return the next ) 0 EXIT THEN DUP $7f > IF DROP 0 EXIT THEN DUP _shift? IF DROP 1 PS2_SHIFT C! 0 EXIT THEN ( ah, finally, we have a gentle run-of-the-mill KC ) PS2_CODES PS2_SHIFT C@ IF $80 + THEN + C@ ( c, maybe 0 ) ?DUP ( c? f ) ; \ SD Card subsystem Load range: B250-B258 SDC_MEM CONSTANT SDC_SDHC : _idle ( -- n ) $ff (spix) ; ( spix $ff until the response is something else than $ff for a maximum of 20 times. Returns $ff if no response. ) : _wait ( -- n ) 0 ( dummy ) 20 >R BEGIN DROP _idle DUP $ff = NOT IF LEAVE THEN NEXT ; ( adjust block for LBA for SD/SDHC ) : _badj ( arg1 arg2 -- arg1 arg2 ) SDC_SDHC @ IF 0 SWAP ELSE DUP 128 / SWAP <<8 << THEN ; ( The opposite of sdcWaitResp: we wait until response is $ff. After a successful read or write operation, the card will be busy for a while. We need to give it time before interacting with it again. Technically, we could continue processing on our side while the card it busy, and maybe we will one day, but at the moment, I'm having random write errors if I don't do this right after a write, so I prefer to stay cautious for now. ) : _ready ( -- ) BEGIN _idle $ff = UNTIL ; ( Computes n into crc c with polynomial $09 Note that the result is "left aligned", that is, that 8th bit to the "right" is insignificant (will be stop bit). ) : _crc7 ( c n -- c ) XOR 8 >R BEGIN ( c ) << ( c<<1 ) DUP >>8 IF ( MSB was set, apply polynomial ) <<8 >>8 $12 XOR ( $09 << 1, we apply CRC on high bits ) THEN NEXT ; ( send-and-crc7 ) : _s+crc ( n c -- c ) SWAP DUP (spix) DROP _crc7 ; ( cmd arg1 arg2 -- resp ) ( Sends a command to the SD card, along with arguments and specified CRC fields. (CRC is only needed in initial commands though). This does *not* handle CS. You have to select/deselect the card outside this routine. ) : _cmd _wait DROP ROT ( a1 a2 cmd ) 0 _s+crc ( a1 a2 crc ) ROT L|M ROT ( a2 h l crc ) _s+crc _s+crc ( a2 crc ) SWAP L|M ROT ( h l crc ) _s+crc _s+crc ( crc ) 1 OR ( ensure stop bit ) (spix) DROP ( send CRC ) _wait ( wait for a valid response... ) ; ( cmd arg1 arg2 -- r ) ( Send a command that expects a R1 response, handling CS. ) : SDCMDR1 [ SDC_DEVID LITN ] (spie) _cmd 0 (spie) ; ( cmd arg1 arg2 -- r arg1 arg2 ) ( Send a command that expects a R7 response, handling CS. A R7 is a R1 followed by 4 bytes. arg1 contains bytes 0:1, arg2 has 2:3 ) : SDCMDR7 [ SDC_DEVID LITN ] (spie) _cmd ( r ) _idle <<8 _idle + ( r arg1 ) _idle <<8 _idle + ( r arg1 arg2 ) 0 (spie) ; : _rdsdhc ( -- ) $7A ( CMD58 ) 0 0 SDCMDR7 DROP $4000 AND SDC_SDHC ! DROP ; : _err 0 (spie) S" SDerr" STYPE ABORT ; ( Tight definition ahead, pre-comment. Initialize a SD card. This should be called at least 1ms after the powering up of the card. We begin by waking up the SD card. After power up, a SD card has to receive at least 74 dummy clocks with CS and DI high. We send 80. Then send cmd0 for a maximum of 10 times, success is when we get $01. Then comes the CMD8. We send it with a $01aa argument and expect a $01aa argument back, along with a $01 R1 response. After that, we need to repeatedly run CMD55+CMD41 ($40000000) until the card goes out of idle mode, that is, when it stops sending us $01 response and send us $00 instead. Any other response means that initialization failed. ) : SDC$ 10 >R BEGIN _idle DROP NEXT 0 ( dummy ) 10 >R BEGIN ( r ) DROP $40 0 0 SDCMDR1 ( CMD0 ) 1 = DUP IF LEAVE THEN NEXT NOT IF _err THEN $48 0 $1aa ( CMD8 ) SDCMDR7 ( r arg1 arg2 ) ( expected 1 0 $1aa ) $1aa = ROT ( arg1 f r ) 1 = AND SWAP ( f&f arg1 ) NOT ( 0 expected ) AND ( f&f&f ) NOT IF _err THEN BEGIN $77 0 0 SDCMDR1 ( CMD55 ) 1 = NOT IF _err THEN $69 $4000 0 SDCMDR1 ( CMD41 ) DUP 1 > IF _err THEN NOT UNTIL _rdsdhc ; ( out of idle mode, success! ) :~ ( dstaddr blkno -- ) [ SDC_DEVID LITN ] (spie) $51 ( CMD17 ) SWAP _badj ( a cmd arg1 arg2 ) _cmd IF _err THEN _wait $fe = NOT IF _err THEN >A 512 >R 0 BEGIN ( crc1 ) _idle ( crc1 b ) DUP AC!+ ( crc1 b ) CRC16 NEXT ( crc1 ) _idle <<8 _idle + ( crc1 crc2 ) _wait DROP 0 (spie) = NOT IF _err THEN ; : SDC@ ( blkno blk( -- ) SWAP << ( 2x ) 2DUP ( a b a b ) ~ ( a b ) 1+ SWAP 512 + SWAP ~ ; :~ ( srcaddr blkno -- ) [ SDC_DEVID LITN ] (spie) $58 ( CMD24 ) SWAP _badj ( a cmd arg1 arg2 ) _cmd IF _err THEN _idle DROP $fe (spix) DROP >A 512 >R 0 BEGIN ( crc ) AC@+ ( crc b ) DUP (spix) DROP CRC16 NEXT ( crc ) DUP >>8 ( crc msb ) (spix) DROP (spix) DROP _wait $1f AND 5 = NOT IF _err THEN _ready 0 (spie) ; : SDC! ( blkno blk( -- ) SWAP << ( 2x ) 2DUP ( a b a b ) ~ ( a b ) 1+ SWAP 512 + SWAP ~ ; Fonts Fonts are kept in "source" form in the following blocks and then compiled to binary bitmasks by the following code. In source form, fonts are a simple sequence of '.' and 'X'. '.' means empty, 'X' means filled. Glyphs are entered one after the other, starting at $21 and ending at $7e. To be space efficient in blocks, we align glyphs horizontally in the blocks to fit as many character as we can. For example, a 5x7 font would mean that we would have 12x2 glyphs per block. 261 Font compiler 265 3x5 font 267 5x7 font 271 7x7 font \ Converts "dot-X" fonts to binary "glyph rows". One byte for \ each row. In a 5x7 font, each glyph thus use 7 bytes. \ Resulting bytes are aligned to the left of the byte. \ Therefore, for a 5-bit wide char, "X.X.X" translates to \ 10101000. Left-aligned bytes are easier to work with when \ compositing glyphs. 2 VALUES _w _h : _g ( given a top-left of dot-X in BLK(, spit H bin lines ) DUP >A _h >R BEGIN _w >R 0 BEGIN ( a r ) << AC@+ 'X' = IF 1+ THEN NEXT 8 _w - LSHIFT C, 64 + DUP >A NEXT DROP ; : _l ( a u -- a, spit a line of u glyphs ) >R DUP BEGIN ( a ) DUP _g _w + NEXT DROP ; : CPFNT3x5 3 TO _w 5 TO _h _h ALLOT0 ( space char ) 265 BLK@ BLK( 21 _l 320 + 21 _l 320 + 21 _l DROP ( 63 ) 266 BLK@ BLK( 21 _l 320 + 10 _l DROP ( 94! ) ; : CPFNT5x7 5 TO _w 7 TO _h _h ALLOT0 ( space char ) 3 >R 267 BEGIN ( b ) DUP BLK@ BLK( 12 _l 448 + 12 _l DROP 1+ NEXT ( 72 ) ( 270 ) BLK@ BLK( 12 _l 448 + 10 _l DROP ( 94! ) ; : CPFNT7x7 7 TO _w 7 TO _h _h ALLOT0 ( space char ) 5 >R 271 BEGIN ( b ) DUP BLK@ BLK( 9 _l 448 + 9 _l DROP 1+ NEXT ( 90 ) ( 276 ) BLK@ BLK( 4 _l DROP ( 94! ) ; .X.X.XX.X.XXX...X..X...XX...X...............X.X..X.XX.XX.X.XXXX .X.X.XXXXXX...XX.X.X..X..X.XXX.X............XX.XXX...X..XX.XX.. .X........XX.X..X.....X..X..X.XXX...XXX....X.X.X.X..X.XX.XXXXX. ......XXXXX.X..X.X....X..X.X.X.X..X.......X..X.X.X.X....X..X..X .X....X.X.X...X.XX.....XX........X......X.X...X.XXXXXXXX...XXX. .XXXXXXXXXXX........X...X..XX..X..X.XX..XXXX.XXXXXX.XXX.XXXXXXX X....XX.XX.X.X..X..X.XXX.X...XXXXX.XX.XX..X.XX..X..X..X.X.X...X XXX.X.XXXXXX......X.......X.X.XXXXXXXX.X..X.XXX.XX.X.XXXX.X...X X.XX..X.X..X.X..X..X.XXX.X....X..X.XX.XX..X.XX..X..X.XX.X.X...X XXXX..XXXXX....X....X...X...X..XXX.XXX..XXXX.XXXX...XXX.XXXXXX. X.XX..X.XXX.XXXXX.XXXXX..XXXXXX.XX.XX.XX.XX.XXXXXXXX..XXX.X.... XX.X..XXXX.XX.XX.XX.XX.XX...X.X.XX.XX.XX.XX.X..XX..X....XX.X... X..X..XXXX.XX.XXX.X.XXX..X..X.X.XX.XXXX.X..X..X.X...X...X...... XX.X..X.XX.XX.XX..XXXX.X..X.X.X.XX.XXXXX.X.X.X..X....X..X...... X.XXXXX.XX.XXXXX...XXX.XXX..X.XXX.X.X.XX.X.X.XXXXXX..XXXX...XXX !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_ X.....X.......X....XX...X...X...XX..XX.......................X. .X.XX.X...XX..X.X.X...X.X........X.X.X.X.XXX..X.XX..XX.XX.XXXXX .....XXX.X...XXX.XXX.X.XXX..X...XXX..X.XXXX.XX.XX.XX.XX..XX..X. ...XXXX.XX..X.XXX.X...XXX.X.X...XX.X.X.X.XX.XX.XXX..XXX....X.X. ...XXXXX..XX.XX.XXX..XX.X.X.X.XX.X.X.XXX.XX.X.X.X....XX..XX..XX ...................XX.X.XX..................................... X.XX.XX.XX.XX.XXXX.X..X..X..XX X.XX.XX.X.X..X..XXX...X...XXX. X.XX.XXXX.X..X.XX..X..X..X.... XXX.X.X.XX.X.X.XXX.XX.X.XX.... `abcdefghijklmnopqrstuvwxyz{|}~ ..X...X.X........X..............X....X....X................. ..X...X.X..X.X..XXXXX...X.XX....X...X......X.X.X.X..X....... ..X.......XXXXXX.......X.X..X......X........X.XXX...X....... ..X........X.X..XXX...X...XX.......X........XXXXXXXXXXX..... ..........XXXXX....X.X....XX.X.....X........X.XXX...X....... ..X........X.X.XXXX.X...XX..X.......X......X.X.X.X..X.....X. ..X..............X.......XXX.X.......X....X..............X.. ................XXX...XX..XXX..XXX...XX.XXXXX.XXX.XXXXX.XXX. ..............XX...X.X.X.X...XX...X.X.X.X....X........XX...X .............X.X..XX...X.....X....XX..X.XXXX.X........XX...X XXXXX.......X..X.X.X...X....X...XX.XXXXX....XXXXX....X..XXX. ...........X...XX..X...X...X......X...X.....XX...X..X..X...X ......XX..X....X...X...X..X...X...X...X.X...XX...X.X...X...X ......XX........XXX..XXXXXXXXX.XXX....X..XXX..XXX.X.....XXX. !"#$%&'()*+,-./012345678 .XXX...............X.....X.....XXX..XXX..XXX.XXXX..XXX.XXXX. X...X..X....X....XX.......XX..X...XX...XX...XX...XX...XX...X X...X..X....X...XX..XXXXX..XX.....XX..XXX...XX...XX....X...X .XXX...........X.............X...X.X..XXXXXXXXXXX.X....X...X ....X..X....X...XX..XXXXX..XX...X..X....X...XX...XX....X...X ....X..X...X.....XX.......XX.......X...XX...XX...XX...XX...X .XXX...............X.....X......X...XXX.X...XXXXX..XXX.XXXX. XXXXXXXXXX.XXX.X...X.XXX....XXX..X.X....X...XX...X.XXX.XXXX. X....X....X...XX...X..X......XX.X..X....XX.XXXX..XX...XX...X X....X....X....X...X..X......XXX...X....X.X.XXX..XX...XX...X XXXX.XXXX.X..XXXXXXX..X......XX....X....X...XX.X.XX...XXXXX. X....X....X...XX...X..X......XXX...X....X...XX..XXX...XX.... X....X....X...XX...X..X..X...XX.X..X....X...XX..XXX...XX.... XXXXXX.....XXX.X...X.XXX..XXX.X..X.XXXXXX...XX...X.XXX.X.... 9:;<=>?@ABCDEFGHIJKLMNOP .XXX.XXXX..XXX.XXXXXX...XX...XX...XX...XX...XXXXXXXXX....... X...XX...XX...X..X..X...XX...XX...XX...XX...XX...XX....X.... X...XX...XX......X..X...XX...XX...X.X.X..X.X....X.X.....X... X...XXXXX..XXX...X..X...XX...XX...X..X....X....X..X......X.. X.X.XX.X......X..X..X...XX...XX.X.X.X.X...X...X...X.......X. X..XXX..X.X...X..X..X...X.X.X.X.X.XX...X..X..X...XX........X .XXXXX...X.XXX...X...XXX...X...X.X.X...X..X..XXXXXXXX....... ..XXX..X.........X.......................................... ....X.X.X.........X......................................... ....XX...X...........XXX.X.....XXX.....X.XXX..XX....XXXX.... ....X...................XX....X...X....XX...XX..X..X..XX.... ....X................XXXXXXX..X......XXXXXXXXX......XXXXXX.. ....X...............X...XX..X.X...X.X..XX....XXX......XX..X. ..XXX.....XXXXX......XXXXXXX...XXX...XXX.XXXXX......XX.X..X. QRSTUVWXYZ[\]^_`abcdefgh ............................................................ ............................................................ ..X......XX..X..XX...X.X.XXX...XXX.XXX....XXXX.XX..XXX..X... ..........X.X....X..X.X.XX..X.X...XX..X..X..XXX...X....XXX.. ..X......XXX.....X..X...XX...XX...XXXX....XXXX.....XXX..X... ..X...X..XX.X....X..X...XX...XX...XX........XX........X.X... ..X....XX.X..X...XX.X...XX...X.XXX.X........XX.....XXX...XX. ................................XX...X...XX....... ...............................X.....X.....X...... X...XX...XX...XX...XX...XXXXXX.X.....X.....X..X.X. X...XX...XX...X.X.X..X.X....X.X......X......XX.X.. X...XX...XX...X..X....X....X...X.....X.....X...... X...X.X.X.X.X.X.X.X..X....X....X.....X.....X...... .XXX...X...X.X.X...XX....XXXXX..XX...X...XX....... ijklmnopqrstuvwxyz{|}~ ..XX....XX.XX..XX.XX....XX..XX......XXX......XX.....XX...XX.... ..XX....XX.XX..XX.XX..XXXXXXXX..XX.XX.XX....XX.....XX.....XX... ..XX....XX.XX.XXXXXXXXX.X......XX..XX.XX...XX.....XX.......XX.. ..XX...........XX.XX..XXXXX...XX....XXX...........XX.......XX.. ..XX..........XXXXXXX...X.XX.XX....XX.XX.X........XX.......XX.. ...............XX.XX.XXXXXX.XX..XX.XX..XX..........XX.....XX... ..XX...........XX.XX...XX.......XX..XXX.XX..........XX...XX.... ...........................................XXXX....XX....XXXX.. ..XX.....XX............................XX.XX..XX..XXX...XX..XX. XXXXXX...XX...........................XX..XX.XXX...XX.......XX. .XXXX..XXXXXX........XXXXXX..........XX...XXXXXX...XX......XX.. XXXXXX...XX.........................XX....XXX.XX...XX.....XX... ..XX.....XX.....XX............XX...XX.....XX..XX...XX....XX.... ...............XX.............XX...........XXXX..XXXXXX.XXXXXX. !"#$%&'()*+,-./012 .XXXX.....XX..XXXXXX...XXX..XXXXXX..XXXX...XXXX................ XX..XX...XXX..XX......XX........XX.XX..XX.XX..XX............... ....XX..XXXX..XXXXX..XX........XX..XX..XX.XX..XX...XX.....XX... ..XXX..XX.XX......XX.XXXXX....XX....XXXX...XXXXX...XX.....XX... ....XX.XXXXXX.....XX.XX..XX..XX....XX..XX.....XX............... XX..XX....XX..XX..XX.XX..XX..XX....XX..XX....XX....XX.....XX... .XXXX.....XX...XXXX...XXXX...XX.....XXXX...XXX.....XX....XX.... ...XX.........XX......XXXX...XXXX...XXXX..XXXXX...XXXX..XXXX... ..XX...........XX....XX..XX.XX..XX.XX..XX.XX..XX.XX..XX.XX.XX.. .XX....XXXXXX...XX......XX..XX.XXX.XX..XX.XX..XX.XX.....XX..XX. XX...............XX....XX...XX.X.X.XXXXXX.XXXXX..XX.....XX..XX. .XX....XXXXXX...XX.....XX...XX.XXX.XX..XX.XX..XX.XX.....XX..XX. ..XX...........XX...........XX.....XX..XX.XX..XX.XX..XX.XX.XX.. ...XX.........XX.......XX....XXXX..XX..XX.XXXXX...XXXX..XXXX... 3456789:;<=>?@ABCD XXXXXX.XXXXXX..XXXX..XX..XX.XXXXXX..XXXXX.XX..XX.XX.....XX...XX XX.....XX.....XX..XX.XX..XX...XX......XX..XX.XX..XX.....XXX.XXX XX.....XX.....XX.....XX..XX...XX......XX..XXXX...XX.....XXXXXXX XXXXX..XXXXX..XX.XXX.XXXXXX...XX......XX..XXX....XX.....XX.X.XX XX.....XX.....XX..XX.XX..XX...XX......XX..XXXX...XX.....XX.X.XX XX.....XX.....XX..XX.XX..XX...XX...XX.XX..XX.XX..XX.....XX...XX XXXXXX.XX......XXXX..XX..XX.XXXXXX..XXX...XX..XX.XXXXXX.XX...XX XX..XX..XXXX..XXXXX...XXXX..XXXXX...XXXX..XXXXXX.XX..XX.XX..XX. XX..XX.XX..XX.XX..XX.XX..XX.XX..XX.XX..XX...XX...XX..XX.XX..XX. XXX.XX.XX..XX.XX..XX.XX..XX.XX..XX.XX.......XX...XX..XX.XX..XX. XXXXXX.XX..XX.XXXXX..XX..XX.XXXXX...XXXX....XX...XX..XX.XX..XX. XX.XXX.XX..XX.XX.....XX.X.X.XX.XX......XX...XX...XX..XX.XX..XX. XX..XX.XX..XX.XX.....XX.XX..XX..XX.XX..XX...XX...XX..XX..XXXX.. XX..XX..XXXX..XX......XX.XX.XX..XX..XXXX....XX....XXXX....XX... EFGHIJKLMNOPQRSTUVWXYZ[\]^_ XX...XXXX..XX.XX..XX.XXXXXX.XXXXX.........XXXXX....XX.......... XX...XXXX..XX.XX..XX.....XX.XX.....XX........XX...XXXX......... XX.X.XX.XXXX..XX..XX....XX..XX......XX.......XX..XX..XX........ XX.X.XX..XX....XXXX....XX...XX.......XX......XX..X....X........ XXXXXXX.XXXX....XX....XX....XX........XX.....XX................ XXX.XXXXX..XX...XX...XX.....XX.........XX....XX................ XX...XXXX..XX...XX...XXXXXX.XXXXX.........XXXXX.........XXXXXXX .XX...........XX................XX..........XXX.........XX..... ..XX..........XX................XX.........XX.....XXXX..XX..... ...XX...XXXX..XXXXX...XXXX...XXXXX..XXXX...XX....XX..XX.XXXXX.. ...........XX.XX..XX.XX..XX.XX..XX.XX..XX.XXXXX..XX..XX.XX..XX. ........XXXXX.XX..XX.XX.....XX..XX.XXXXXX..XX.....XXXXX.XX..XX. .......XX..XX.XX..XX.XX..XX.XX..XX.XX......XX........XX.XX..XX. ........XXXXX.XXXXX...XXXX...XXXXX..XXXX...XX.....XXX...XX..XX. WXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ ..XX.....XX...XX......XXX...................................... ..............XX.......XX...................................... .XXX....XXX...XX..XX...XX....XX.XX.XXXXX...XXXX..XXXXX...XXXXX. ..XX.....XX...XX.XX....XX...XXXXXXXXX..XX.XX..XX.XX..XX.XX..XX. ..XX.....XX...XXXX.....XX...XX.X.XXXX..XX.XX..XX.XX..XX.XX..XX. ..XX.....XX...XX.XX....XX...XX.X.XXXX..XX.XX..XX.XXXXX...XXXXX. .XXXX..XX.....XX..XX..XXXX..XX...XXXX..XX..XXXX..XX.........XX. ...............XX.............................................. ...............XX.............................................. XX.XX...XXXXX.XXXXX..XX..XX.XX..XX.XX...XXXX..XX.XX..XX.XXXXXX. XXX.XX.XX......XX....XX..XX.XX..XX.XX.X.XX.XXXX..XX..XX....XX.. XX......XXXX...XX....XX..XX.XX..XX.XX.X.XX..XX...XX..XX...XX... XX.........XX..XX....XX..XX..XXXX..XXXXXXX.XXXX...XXXXX..XX.... XX.....XXXXX....XXX...XXXXX...XX....XX.XX.XX..XX.....XX.XXXXXX. ijklmnopqrstuvwxyz{|}~ ...XX....XX...XX......XX...X ..XX.....XX....XX....XX.X.XX ..XX.....XX....XX....X...XX. XXX......XX.....XXX......... ..XX.....XX....XX........... ..XX.....XX....XX........... ...XX....XX...XX............ {|}~ \ Automated tests. "1 LOAD 290 296 LOADR" to run. \ "#" means "assert". We ABORT on failure. : fail SPC> ABORT" failed" ; : # IF SPC> ." pass" NL> ELSE fail THEN ; : #eq 2DUP SWAP . SPC> '=' EMIT SPC> . '?' EMIT = # ; \ Arithmetics 48 13 + 61 #eq 48 13 - 35 #eq 48 13 * 624 #eq 48 13 / 3 #eq 48 13 MOD 9 #eq 5 3 LSHIFT 40 #eq 155 5 RSHIFT 4 #eq \ Comparisons $22 $8065 < # -1 0 > # -1 0< # \ Memory 42 C, 43 C, 44 C, HERE 3 - HERE 3 MOVE HERE C@ 42 #eq HERE 1+ C@ 43 #eq HERE 2 + C@ 44 #eq HERE HERE 1+ 3 MOVE ( demonstrate MOVE's problem ) HERE 1+ C@ 42 #eq HERE 2 + C@ 42 #eq HERE 3 + C@ 42 #eq HERE 3 - HERE 3 MOVE HERE HERE 1+ 3 MOVE- ( see? better ) HERE 1+ C@ 42 #eq HERE 2 + C@ 43 #eq HERE 3 + C@ 44 #eq HERE ( ref ) HERE 3 - 3 MOVE, ( ref ) HERE 3 - #eq HERE 3 - C@ 42 #eq HERE 2 - C@ 43 #eq HERE 1- C@ 44 #eq \ Parse 'b' $62 #eq \ Stack 42 43 44 ROT 42 #eq 44 #eq 43 #eq 42 43 44 ROT> 43 #eq 42 #eq 44 #eq \ CRC $0000 $00 CRC16 $0000 #eq $0000 $01 CRC16 $1021 #eq $5678 $34 CRC16 $34e4 #eq
-\ No newline at end of file
+MASTER INDEX 001 Useful little words 010 RX/TX tools 020 Block editor 035 Memory Editor 040 AVR SPI programmer 045 Sega ROM signer 050 Virgil's workspace 060-199 unused 200 Cross compilation 210 Core words 230 BLK subsystem 235 RX/TX subsystem 237 Media Span subsystem 240 Grid subsystem 245 PS/2 keyboard subsystem 250 SD Card subsystem 260 Fonts 280-289 unused 290 Automated tests 300 Arch-specific content \ Useful little words. CRC16[] MOVE- '? CRC16[] [IF] \S [THEN] \ Compute CRC16 over a memory range : CRC16[] ( a u -- c ) >R >A 0 BEGIN AC@+ CRC16 NEXT ; : MOVE- ( a1 a2 u -- ) \ *A* MOVE starting from the end ?DUP IF >R OVER - ( a1 diff ) SWAP R@ + >A BEGIN ( diff ) A- A> OVER + AC@ SWAP C! NEXT DROP ELSE 2DROP THEN ; \ Useful little words. MEM>BLK BLK>MEM \ *A* Copy an area of memory into blocks. : MEM>BLK ( addr blkno blkcnt ) >R BEGIN ( a blk ) DUP BLK@ 1+ SWAP DUP BLK( $400 MOVE BLK!! $400 + SWAP NEXT DROP FLUSH ; \ *A* Copy subsequent blocks in an area of memory : BLK>MEM ( blkno blkcnt addr ) ROT> >R BEGIN ( a blk ) DUP BLK@ 1+ SWAP BLK( OVER $400 MOVE $400 + SWAP NEXT DROP ; \ Context. Allows multiple concurrent dictionaries. \ See doc/usage.txt 0 VALUE saveto \ where to save CURRENT in next switch : context DOER CURRENT , DOES> ( a -- ) saveto IF CURRENT TO saveto THEN ( a ) DUP TO saveto ( a ) @ CURRENT ! ; \ string manipulation. '? >s [IF] \S [THEN] 2 VALUES sa sl : >s ( sa sl -- ) TO sl TO sa ; : s> sa sl ; : cutr ( n -- ) sl -^ DUP 0< IF DROP 0 THEN TO sl ; : cutl ( n -- ) sl SWAP cutr sl - sa + TO sa ; : prefix? ( sa sl -- f ) DUP sl > IF 2DROP 0 EXIT THEN sa ROT> []= ; : suffix? ( sa sl -- f ) DUP sl > IF 2DROP 0 EXIT THEN sl OVER - ( sa sl off ) sa + ( sa sl sa2 ) SWAP []= ; \ Word table. See doc/wordtbl : wordtbl ( n -- a ) create here swap << allot0 1 here c! ; : w+ ( a -- a+2? ) 1+ 1+ dup @ if drop then ; : :w ( a -- a+2? ) here xtcomp over ! w+ ; : 'w ( a -- a+2? ) ' over ! w+ ; : wexec ( tbl idx -- ) << + @ execute ; \ Pager. See doc/pager 4 VALUES ''EMIT ''KEY? chrcnt lncnt 20 VALUE PGSZ : realKEY BEGIN ''KEY? EXECUTE UNTIL ; : back ''EMIT 'EMIT ! ''KEY? 'KEY? ! ; : emit ( c -- ) chrcnt 1+ TO chrcnt DUP CR = chrcnt LNSZ = OR IF 0 TO chrcnt lncnt 1+ TO lncnt THEN ''EMIT EXECUTE lncnt PGSZ = IF 0 TO lncnt NL> ." Press q to quit, any key otherwise" NL> realKEY 'q' = IF back QUIT THEN THEN ; : key? back KEY? ; : page 'EMIT @ TO ''EMIT 'KEY? @ TO ''KEY? ['] emit 'EMIT ! ['] key? 'KEY? ! ; \ Flow words '? PC NOT [IF] ALIAS HERE PC [THEN] '? PC2A NOT [IF] : PC2A ; [THEN] ALIAS PC BEGIN, : LSET PC TO ; : BR PC - 2 - _bchk ; : FJR BEGIN, 1+ 0 ; : IFZ, FJR JRNZi, ; : IFNZ, FJR JRZi, ; : IFC, FJR JRNCi, ; : IFNC, FJR JRCi, ; \ warning: l is a PC value, not a mem addr! \ also, in 6502, JRi, is 3b instead of 2, hence the hack. : FMARK ( l -- ) PC2A DUP C@ IF ( hack ) 1+ THEN DUP HERE -^ 1- SWAP C! ; : THEN, FMARK ; : ELSE, FJR JRi, SWAP FMARK ; \ Communicate blocks with block server. See doc/blksrv. CREATE h16 '$' C, 4 ALLOT : RX>h16 ( -- n ) \ *A* h16 1+ >A 4 >R BEGIN RX< DUP EMIT SPC> AC!+ NEXT h16 5 PARSE NOT IF 0 THEN ; : csumchk ( c1 c2 ) = NOT IF ABORT" bad csum" THEN ; : blksrv< ( blkno -- ) \ *A* RX<< TX[ 'G' EMIT .X ]TX 0 ( csum ) BLK( >A 1024 >R BEGIN RX< DUP AC!+ + NEXT RX>h16 csumchk ; : blksrv> ( blkno -- ) \ *A* RX<< TX[ 'P' EMIT .X ]TX 0 ( csum ) BLK( >A 1024 >R BEGIN AC@+ DUP TX> + NEXT TX[ .X ]TX ; \ Remote shell. See doc/rxtx : RX<?? RX<? ?DUP NOT IF 100 TICKS RX<? THEN ; : _<< \ print everything available from RX<? BEGIN RX<?? IF EMIT ELSE EXIT THEN AGAIN ; : _<<1r RX< EMIT _<< ; : rsh BEGIN KEY? IF DUP EOT = IF DROP EXIT ELSE TX> THEN THEN _<< AGAIN ; \ rupload. See doc/rxtx : CR> CR EMIT ; : unpack DUP $f0 OR SWAP $0f OR ; : out unpack TX> TX> ; : out2 L|M out out ; : rdok \ read RX until after "ok" BEGIN RX< WS? NOT UNTIL _<<1r ; : rupload ( loca rema u -- ) TX[ ." : in KEY $f0 AND KEY $0f AND OR ;" CR> rdok ." : in2 in <<8 in OR ;" CR> rdok \ sig: chk -- chk, a and then u are KEYed in ." : _ in2 >A in2 >R BEGIN in TUCK + SWAP AC!+ NEXT ;" CR> rdok DUP ROT ( loca u u rema ) ." 0 _" CR> out2 out2 ]TX >R >A 0 BEGIN ( chk ) '.' EMIT AC@ out AC@+ + NEXT _<<1r TX[ ." .X FORGET in" CR> ]TX rdok .X ; \ XMODEM routines. See doc/rxtx : _<<s BEGIN RX<? IF DROP ELSE EXIT THEN AGAIN ; : _rx>mem1 ( addr -- f, Receive single packet, f=eot ) RX< 1 = NOT IF ( EOT ) $6 ( ACK ) TX> 1 EXIT THEN '.' EMIT RX< RX< 2DROP ( packet num ) >A 0 ( crc ) 128 >R BEGIN ( crc ) RX< DUP ( crc n n ) AC!+ ( crc n ) CRC16 NEXT RX< <<8 RX< OR ( sender's CRC ) = IF $6 ( ACK ) ELSE $15 'N' EMIT ( NACK ) THEN TX> 0 ; : RX>MEM ( addr --, Receive packets into addr until EOT ) _<<s 'C' TX> BEGIN ( a ) DUP _rx>mem1 SWAP 128 + SWAP UNTIL DROP ; : RX>BLK ( -- ) _<<s 'C' TX> BLK( BEGIN ( a ) DUP BLK) = IF DROP BLK( BLK! BLK> 1+ 'BLK> ! THEN DUP _rx>mem1 SWAP 128 + SWAP UNTIL 2DROP ; : _snd128 ( A:a -- A:a ) 0 128 >R BEGIN ( crc ) AC@+ DUP TX> ( crc n ) CRC16 ( crc ) NEXT L|M TX> TX> ; : _ack? 0 BEGIN DROP RX< DUP 'C' = NOT UNTIL DUP $06 ( ACK ) = IF DROP 1 ELSE $15 = NOT IF ABORT" out of sync" THEN 0 THEN ; : _waitC ." Waiting for C..." BEGIN RX<? IF 'C' = ELSE 0 THEN UNTIL ; : _mem>tx ( addr pktstart pktend -- ) OVER - >R SWAP >A BEGIN ( pkt ) 'P' EMIT DUP . SPC> $01 ( SOH ) TX> ( pkt ) 1+ ( pkt start at 1 ) DUP TX> $ff OVER - TX> ( pkt+1 ) _snd128 _ack? NOT IF LEAVE THEN NEXT DROP ; : MEM>TX ( a u -- Send u bytes to TX ) _waitC 128 /MOD SWAP IF 1+ THEN ( pktcnt ) 0 SWAP _mem>tx $4 ( EOT ) TX> RX< DROP ; : BLK>TX ( b1 b2 -- ) _waitC OVER - ( cnt ) >R BEGIN ( blk ) 'B' EMIT DUP . SPC> DUP BLK@ BLK( ( blk a ) OVER 8 * DUP 8 + ( a pktstart pktend ) _mem>tx 1+ NEXT $4 ( EOT ) TX> RX< DROP ; \ Block editor. see doc/ed. \ Cursor position in buffer. EDPOS/64 is line number 0 VALUE EDPOS CREATE IBUF LNSZ 1+ ALLOT0 \ counted string, first byte is len CREATE FBUF LNSZ 1+ ALLOT0 : L BLK> ." Block " DUP . NL> LIST ; : B BLK> 1- BLK@ L ; : N BLK> 1+ BLK@ L ; : IBUF+ IBUF 1+ ; : FBUF+ FBUF 1+ ; : ILEN IBUF C@ ; : FLEN FBUF C@ ; : EDPOS! TO EDPOS ; : EDPOS+! EDPOS + EDPOS! ; : 'pos ( pos -- a, addr of pos in memory ) BLK( + ; : 'EDPOS EDPOS 'pos ; \ Block editor, private helpers : _lpos ( ln -- a ) LNSZ * 'pos ; : _pln ( ln -- ) \ print line no ln with pos caret DUP _lpos DUP >A LNLEN 1 MAX >R BEGIN ( lno ) A> 'EDPOS = IF '^' EMIT THEN AC@+ SPC MAX EMIT NEXT ( lno ) SPC> 1+ . ; : _zline ( a -- ) LNSZ SPC FILL ; \ zero-out a line : _type ( buf -- ) \ *A* type into buf until end of INBUF IN<? ?DUP NOT IF DROP EXIT THEN OVER 1+ DUP _zline >A BEGIN ( buf c ) AC!+ IN<? ?DUP NOT UNTIL ( buf ) A> OVER - 1- ( buf len ) SWAP C! ; \ Block editor, T P U \ user-facing lines are 1-based : T 1- DUP LNSZ * EDPOS! _pln ; : P IBUF _type IBUF+ 'EDPOS LNSZ MOVE BLK!! ; : _mvln+ ( ln -- move ln 1 line down ) DUP 14 > IF DROP EXIT THEN _lpos DUP LNSZ + LNSZ MOVE ; : _U ( U without P, used in VE ) 15 EDPOS LNSZ / - ?DUP IF >R 14 BEGIN DUP _mvln+ 1- NEXT DROP THEN ; : U _U P ; \ Block editor, F i : _F ( F without _type and _pln. used in VE ) 'EDPOS 1+ BEGIN ( a ) FBUF+ C@ OVER BLK) OVER - ( a c a u ) [C]? DUP 0< IF 2DROP EXIT THEN ( a idx ) + ( a ) DUP FBUF+ FLEN []= IF BLK( - EDPOS! EXIT THEN 1+ AGAIN ; : F FBUF _type _F EDPOS LNSZ / _pln ; : _rbufsz ( size of linebuf to the right of curpos ) EDPOS LNSZ MOD LNSZ -^ ; : _I ( I without _pln and _type. used in VE ) _rbufsz ILEN OVER < IF ( rsize ) ILEN - ( chars-to-move ) 'EDPOS DUP ILEN + ROT ( a a+ilen ctm ) MOVE- ILEN THEN ( len-to-insert ) IBUF+ 'EDPOS ROT MOVE ( ilen ) BLK!! ; : I IBUF _type _I EDPOS LNSZ / _pln ; \ Block editor, X E Y : icpy ( n -- copy n chars from cursor to IBUF ) DUP IBUF C! IBUF+ _zline 'EDPOS IBUF+ ( n a buf ) ROT MOVE ; : _del ( n -- ) ?DUP NOT IF EXIT THEN _rbufsz MIN 'EDPOS 2DUP + ( n a1 a1+n ) SWAP _rbufsz MOVE ( n ) \ get to next line - n DUP EDPOS $ffc0 AND $40 + -^ 'pos ( n a ) SWAP SPC FILL BLK!! ; : _X ( n -- ) ?DUP NOT IF EXIT THEN _rbufsz MIN DUP icpy _del ; : X _X EDPOS LNSZ / _pln ; : _E FLEN _X ; : E FLEN X ; : Y FBUF IBUF LNSZ 1+ MOVE ; \ Visual text editor. VALUEs, lg? width pos@ mode! ... 3 VALUES PREVPOS xoff ACC LNSZ 3 + VALUE MAXW 10 VALUE MARKCNT CREATE MARKS MARKCNT << << ALLOT0 \ 4b: blk/edpos : nspcs ( pos n ) SPC FILLC ; : lg? COLS MAXW > ; : col- MAXW COLS MIN -^ ; : width lg? IF LNSZ ELSE COLS THEN ; : acc@ ACC 1 MAX ; : pos@ ( x y -- ) EDPOS LNSZ /MOD ; : num ( c -- ) \ c is in range 0-9 '0' - ACC 10 * + TO ACC ; : mode! ( c -- ) 4 col- CELL! ; \ VE, rfshln contents selblk pos! xoff? setpos : _ ( ln -- ) \ refresh line ln DUP _lpos xoff + SWAP 3 + COLS * lg? IF 3 + THEN width CELLS! ; : rfshln pos@ NIP _ ; \ refresh active line : contents 16 >R 0 BEGIN DUP _ 1+ NEXT DROP ; : selblk BLK@ contents ; : pos! ( newpos -- ) EDPOS TO PREVPOS DUP 0< IF DROP 0 THEN 1023 MIN EDPOS! ; : xoff? pos@ DROP ( x ) xoff ?DUP IF < IF 0 TO xoff contents THEN ELSE width >= IF LNSZ COLS - TO xoff contents THEN THEN ; : setpos ( -- ) pos@ 3 + ( header ) SWAP ( y x ) xoff - lg? IF 3 + ( gutter ) THEN SWAP AT-XY ; : 'mark ( -- a ) ACC MARKCNT MOD << << MARKS + ; \ VE, cmv buftype bufprint bufs : cmv ( n -- , char movement ) acc@ * EDPOS + pos! ; : buftype ( buf ln -- ) \ type into buf at ln 3 OVER AT-XY KEY DUP SPC < IF 2DROP DROP EXIT THEN ( b ln c ) SWAP COLS * 3 + 3 col- nspcs ( buf c ) IN( SWAP LNTYPE DROP BEGIN ( buf a ) KEY LNTYPE UNTIL IN( - ( buf len ) SWAP C!+ IN( SWAP LNSZ MOVE IN$ ; : _ ( buf sa sl pos ) DUP >R STYPEC ( buf ) C@+ ( buf sz ) R> 3 + STYPEC ; : bufs ( -- ) \ refresh I and F lines IBUF S" I: " COLS _ FBUF S" F: " COLS 2 * _ ; : insl _U EDPOS $3c0 AND DUP pos! 'pos _zline BLK!! contents ; \ VE cmds 31 VALUE cmdcnt CREATE cmdl ," G[]IFnNYEXChlkjHLg@!wWb&mtfROoD" cmdcnt WORDTBL cmds :W ( G ) ACC selblk ; :W ( [ ) BLK> acc@ - selblk ; :W ( ] ) BLK> acc@ + selblk ; : insert 'I' mode! IBUF 1 buftype _I bufs rfshln ; 'W insert ( I ) :W ( F ) 'F' mode! FBUF 2 buftype _F bufs setpos ; :W ( n ) _F setpos ; :W ( N ) EDPOS _F EDPOS = IF 0 EDPOS! acc@ >R BEGIN BLK> 1+ BLK@ _F EDPOS IF LEAVE THEN NEXT contents setpos THEN ; :W ( Y ) Y bufs ; :W ( E ) _E bufs rfshln ; :W ( X ) acc@ _X bufs rfshln ; :W ( C ) FLEN _del rfshln insert ; \ VE cmds :W ( h ) -1 cmv ; :W ( l ) 1 cmv ; :W ( k ) -64 cmv ; :W ( j ) 64 cmv ; : bol EDPOS $3c0 AND pos! ; 'W bol ( H ) :W ( L ) EDPOS DUP $3f OR 2DUP = IF 2DROP EXIT THEN SWAP BEGIN ( res p ) 1+ DUP 'pos C@ WS? NOT IF NIP DUP 1+ SWAP THEN DUP $3f AND $3f = UNTIL DROP pos! ; :W ( g ) ACC 1 MAX 1- 64 * pos! ; :W ( @ ) BLK> BLK( (blk@) 0 BLKDTY ! contents ; :W ( ! ) BLK> FLUSH 'BLK> ! ; \ VE cmds : C@- DUP 1- SWAP C@ ; : word>> BEGIN C@+ WS? UNTIL ; : ws>> BEGIN C@+ WS? NOT UNTIL ; : word<< BEGIN C@- WS? UNTIL ; : ws<< BEGIN C@- WS? NOT UNTIL ; : bpos! BLK( - pos! ; :W ( w ) 'EDPOS acc@ >R BEGIN word>> ws>> NEXT 1- bpos! ; :W ( W ) 'EDPOS acc@ >R BEGIN ws>> word>> NEXT 1- bpos! ; :W ( b ) 'EDPOS acc@ >R BEGIN 1- ws<< word<< NEXT 1+ 1+ bpos! ; :W ( & ) WIPE contents ; :W ( m ) BLK> 'mark ! EDPOS 'mark 1+ 1+ ! ; :W ( t ) 'mark 1+ 1+ @ pos! 'mark @ selblk ; \ VE cmds :W ( f ) EDPOS PREVPOS 2DUP = IF 2DROP EXIT THEN 2DUP > IF DUP pos! SWAP THEN ( p1 p2, p1 < p2 ) OVER - LNSZ MIN ( pos len ) DUP FBUF C! FBUF+ _zline SWAP 'pos FBUF+ ( len src dst ) ROT MOVE bufs ; :W ( R ) 'R' mode! BEGIN setpos KEY DUP BS? IF -1 EDPOS+! DROP 0 THEN DUP SPC >= IF DUP EMIT 'EDPOS C! 1 EDPOS+! BLK!! 0 THEN UNTIL ; 'W insl ( O ) :W ( o ) EDPOS $3c0 < IF EDPOS 64 + EDPOS! insl THEN ; :W ( D ) bol LNSZ icpy acc@ LNSZ * ( delsz ) BLK) 'EDPOS - MIN >R 'EDPOS R@ + 'EDPOS ( src dst ) BLK) OVER - MOVE BLK) R@ - R> SPC FILL BLK!! bufs contents ; \ VE final: status nums gutter handle VE : status 0 $20 nspcs 0 0 AT-XY ." BLK" SPC> BLK> . SPC> ACC . SPC> pos@ 1+ . ',' EMIT . xoff IF '>' EMIT THEN SPC> BLKDTY @ IF '*' EMIT THEN SPC mode! ; : nums 16 >R BEGIN R@ HERE FMTD R@ 2 + COLS * STYPEC NEXT ; : gutter lg? IF 19 >R BEGIN '|' R@ 1- COLS * MAXW + CELL! NEXT THEN ; : handle ( c -- f ) DUP '0' '9' =><= IF num 0 EXIT THEN DUP cmdl cmdcnt [C]? 1+ ?DUP IF 1- cmds SWAP WEXEC THEN 0 TO ACC 'q' = ; : VE BLK> 0< IF 0 BLK@ THEN CLRSCR 0 TO ACC 0 TO PREVPOS nums bufs contents gutter BEGIN xoff? status setpos KEY handle UNTIL 0 19 AT-XY ; \ Memory Editor. See doc/me CREATE CMD '#' C, 0 C, CREATE BUF '$' C, 4 ALLOT \ always hex \ POS is relative to ADDR 4 VALUES ADDR POS HALT? ASCII? 16 VALUE AWIDTH LINES 2 - VALUE AHEIGHT AHEIGHT AWIDTH * VALUE PAGE COLS 33 < [IF] 8 TO AWIDTH [THEN] : addr ADDR POS + ; CREATE _ ," 0123456789abcdef" : hex! ( c pos -- ) OVER 16 / _ + C@ OVER CELL! ( c pos ) 1+ SWAP $f AND _ + C@ SWAP CELL! ; : bottom 0 LINES 1- AT-XY ; \ Memory Editor, line rfshln contents showpos : line ( ln -- ) DUP AWIDTH * ADDR + >A 1+ COLS * ( pos ) ':' OVER CELL! A> <<8 >>8 OVER 1+ hex! 4 + ( pos+4 ) AWIDTH >> >R A> SWAP BEGIN ( a-old pos ) AC@+ ( a-old pos c ) OVER hex! ( a-old pos ) 1+ 1+ AC@+ OVER hex! 3 + ( a-old pos+5 ) NEXT SWAP >A AWIDTH >R BEGIN ( pos ) AC@+ DUP SPC - $5e > IF DROP '.' THEN OVER CELL! 1+ NEXT DROP ; : rfshln POS AWIDTH / line ; : contents LINES 2 - >R BEGIN R@ 1- line NEXT ; : showpos POS AWIDTH /MOD ( r q ) 1+ SWAP ( y r ) ASCII? IF AWIDTH >> 5 * + ELSE DUP 1 AND << SWAP >> 5 * + THEN 4 + ( y x ) SWAP AT-XY ; \ Memory Editor, addr! pos! status type typep : addr! $fff0 AND TO ADDR contents ; : pos! DUP 0< IF PAGE + THEN DUP PAGE >= IF PAGE - THEN TO POS showpos ; : status 0 COLS SPC FILLC 0 0 AT-XY ." A: " ADDR .X SPC> ." C: " POS .X SPC> ." S: " PSDUMP POS pos! ; : type ( cnt -- sa sl ) BUF 1+ >A >R BEGIN KEY DUP SPC < IF DROP LEAVE ELSE DUP EMIT AC!+ THEN NEXT BUF A> BUF - ; : typep ( cnt -- n? f ) type ( sa sl ) DUP IF PARSE ELSE NIP THEN ; \ Memory Editor, almost all actions : #] ADDR PAGE + addr! ; : #[ ADDR PAGE - addr! ; : #J ADDR $10 + addr! POS $10 - pos! ; : #K ADDR $10 - addr! POS $10 + pos! ; : #l POS 1+ pos! ; : #h POS 1- pos! ; : #j POS AWIDTH + pos! ; : #k POS AWIDTH - pos! ; : #m addr ; : #@ addr @ ; : #! addr ! contents ; : #g SCNT IF DUP ADDR - PAGE < IF ADDR - pos! ELSE DUP addr! $f AND pos! THEN THEN ; : #G bottom 4 typep IF #g THEN ; : #a ASCII? NOT TO ASCII? showpos ; : #f #@ #g ; : #e #m #f ; : _h SPC> showpos 2 typep ; : _a showpos KEY DUP SPC < IF DROP 0 ELSE DUP EMIT 1 THEN ; : #R BEGIN SPC> ASCII? IF _a ELSE _h THEN ( n? f ) IF addr C! rfshln #l 0 ELSE 1 THEN UNTIL rfshln ; \ Memory Editor, #q handle ME : #q 1 TO HALT? ; : handle ( c -- f ) CMD 1+ C! CMD 2 FIND IF EXECUTE THEN ; : ME 0 TO HALT? CLRSCR contents 0 pos! BEGIN status KEY handle HALT? UNTIL bottom ; \ AVR Programmer, B160-B163. doc/avr.txt \ page size in words, 64 is default on atmega328P 64 VALUE aspfpgsz 0 VALUE aspprevx : _x ( a -- b ) DUP TO aspprevx (spix) ; : _xc ( a -- b ) DUP (spix) ( a b ) DUP aspprevx = NOT IF ABORT" AVR err" THEN ( a b ) SWAP TO aspprevx ( b ) ; : _cmd ( b4 b3 b2 b1 -- r4 ) _xc DROP _xc DROP _xc DROP _x ; : asprdy ( -- ) BEGIN 0 0 0 $f0 _cmd 1 AND NOT UNTIL ; : asp$ ( spidevid -- ) ( RESET pulse ) DUP (spie) 0 (spie) (spie) ( wait >20ms ) 220 TICKS ( enable prog ) $ac (spix) DROP $53 _x DROP 0 _xc DROP 0 _x DROP ; : asperase 0 0 $80 $ac _cmd asprdy ; ( fuse access. read/write one byte at a time ) : aspfl@ ( -- lfuse ) 0 0 0 $50 _cmd ; : aspfh@ ( -- hfuse ) 0 0 $08 $58 _cmd ; : aspfe@ ( -- efuse ) 0 0 $00 $58 _cmd ; : aspfl! ( lfuse -- ) 0 $a0 $ac _cmd ; : aspfh! ( hfuse -- ) 0 $a8 $ac _cmd ; : aspfe! ( efuse -- ) 0 $a4 $ac _cmd ; : aspfb! ( n a --, write word n to flash buffer addr a ) SWAP L|M SWAP ( a hi lo ) ROT ( hi lo a ) DUP ROT ( hi a a lo ) SWAP ( hi a lo a ) 0 $40 ( hi a lo a 0 $40 ) _cmd DROP ( hi a ) 0 $48 _cmd DROP ; : aspfp! ( page --, write buffer to page ) 0 SWAP aspfpgsz * L|M ( 0 lsb msb ) $4c _cmd DROP asprdy ; : aspf@ ( page a -- n, read word from flash ) SWAP aspfpgsz * OR ( addr ) L|M ( lsb msb ) 2DUP 0 ROT> ( lsb msb 0 lsb msb ) $20 _cmd ( lsb msb low ) ROT> 0 ROT> ( low 0 lsb msb ) $28 _cmd <<8 OR ; : aspe@ ( addr -- byte, read from EEPROM ) 0 SWAP L|M SWAP ( 0 msb lsb ) $a0 ( 0 msb lsb $a0 ) _cmd ; : aspe! ( byte addr --, write to EEPROM ) L|M SWAP ( b msb lsb ) $c0 ( b msb lsb $c0 ) _cmd DROP asprdy ; ( Sega ROM signer. See doc/sega.txt ) : segasig ( addr size -- ) $2000 OVER LSHIFT ( a sz bytesz ) $10 - >R ( a sz ) SWAP >A 0 BEGIN ( sz csum ) AC@+ + NEXT ( sz csum ) 'T' AC!+ 'M' AC!+ 'R' AC!+ SPC AC!+ 'S' AC!+ 'E' AC!+ 'G' AC!+ 'A' AC!+ 0 AC!+ 0 AC!+ ( sum's LSB ) DUP AC!+ ( MSB ) >>8 AC!+ ( sz ) 0 AC!+ 0 AC!+ 0 AC!+ $4a + AC!+ ; CREATE MSPAN_DISK 0 C, CREATE (msdsks) 100 C, 100 C, 180 C, 0 C, : _ ( dsk -- ) DUP MSPAN_DISK C! S" Need disk " STYPE . SPC> ; : prompt _ KEY DROP ; : dskchk ( blk -- newblk ) A>R (msdsks) >A BEGIN AC@+ - DUP 0< AC@ NOT OR UNTIL A- AC@ + ( newblk ) A> (msdsks) - ( newblk dsk ) DUP MSPAN_DISK C@ = NOT IF prompt ELSE DROP THEN ( blk ) R>A ; \ utility to quickly examine freshly written asm words 0 VALUE mark : see mark >A HERE mark - >R BEGIN AC@+ .x SPC> NEXT mark 'HERE ! ; \ HERE TO mark \ Cross compilation program, generic part. See doc/cross 0 VALUE BIN( \ binary start in target's addr 0 VALUE XORG \ binary start address in host's addr 0 VALUE BIGEND? \ is target big-endian? 3 VALUES L1 L2 L3 : PC HERE XORG - BIN( + ; : PC2A ( pc -- a ) HERE PC - ( org ) + ; : XSTART ( bin( -- ) TO BIN( HERE TO XORG ; : OALLOT ( oa -- ) XORG + HERE - ALLOT0 ; : |T L|M BIGEND? NOT IF SWAP THEN ; : T! ( n a -- ) SWAP |T ROT C!+ C! ; : T, ( n -- ) |T C, C, ; : T@ C@+ SWAP C@ BIGEND? IF SWAP THEN <<8 OR ; : XCOMPC 201 205 LOADR ; : FONTC 262 263 LOADR ; \ Cross compilation program. COS-specific. See doc/cross : COREL 210 224 LOADR ; : COREH 225 229 LOADR ; : BLKSUB 230 234 LOADR ; : GRIDSUB 240 241 LOADR ; : PS2SUB 246 248 LOADR ; : RXTXSUB 235 LOAD ; : MSPANSUB 237 LOAD ; : SDCSUB 250 258 LOADR ; '? HERESTART NOT [IF] 0 VALUE HERESTART [THEN] 0 VALUE XCURRENT \ CURRENT in target system, in target's addr 8 VALUES lblnext lblcell lbldoes lblxt lblval lblhere lblmain lblboot '? 'A NOT [IF] SYSVARS $06 + VALUE 'A [THEN] '? 'N NOT [IF] SYSVARS $08 + VALUE 'N [THEN] 6 VALUES (n)* (b)* (br)* (?br)* EXIT* (next)* CREATE '~ 2 ALLOT \ Cross compilation program : _xoff ( a -- a ) XORG BIN( - ; : _wl ( w -- len ) 1- C@ $7f AND ; : _ws ( w len -- sa ) - 3 - ; : _xfind ( sa sl -- w? f ) >R >A XCURRENT BEGIN ( w R:sl ) _xoff + DUP _wl R@ = IF ( w ) DUP R@ _ws A> R@ ( w a1 a2 u ) []= IF ( w ) R~ 1 EXIT THEN THEN 3 - ( prev field ) T@ ?DUP NOT UNTIL R~ 0 ( not found ) ; : XFIND ( sa sl -- w ) _xfind NOT IF (wnf) THEN _xoff - ; : X' WORD XFIND ; : '? WORD _xfind DUP IF NIP THEN ; : ENTRY WORD TUCK MOVE, XCURRENT T, C, HERE _xoff - TO XCURRENT ; \ Cross compilation program : ;CODE lblnext JMPi, ; : ALIAS X' ENTRY JMPi, ; : *ALIAS ENTRY JMP(i), ; : CONSTANT ENTRY i>, ;CODE ; : CONSTS >R BEGIN RUN1 CONSTANT NEXT ; : CONSTS+ ( off n -- ) >R BEGIN RUN1 OVER + CONSTANT NEXT DROP ; : *VALUE ENTRY (i)>, ;CODE ; : CREATE ENTRY lblcell CALLi, ; : _ ( lbl str -- ) CURWORD S= IF XCURRENT SWAP TO EXECUTE ELSE DROP THEN ; : CODE ENTRY ['] EXIT* S" EXIT" _ ['] (b)* S" (b)" _ ['] (n)* S" (n)" _ ['] (br)* S" (br)" _ ['] (?br)* S" (?br)" _ ['] (next)* S" (next)" _ ; : LITN DUP $ff > IF (n)* T, T, ELSE (b)* T, C, THEN ; \ Cross compilation program : imm? ( w -- f ) 1- C@ $80 AND ; : compile BEGIN WORD S" ;" S= IF EXIT* T, EXIT THEN CURWORD PARSE IF LITN ELSE CURWORD _xfind IF ( w ) DUP imm? IF ABORT" immed!" THEN _xoff - T, ELSE CURWORD FIND IF ( w ) DUP imm? IF EXECUTE ELSE (wnf) THEN ELSE (wnf) THEN THEN ( _xfind ) THEN ( PARSE ) AGAIN ; : :~ HERE _xoff - '~ ! lblxt CALLi, compile ; : ~ '~ @ T, ; IMMEDIATE : _ CODE lblxt CALLi, compile ; \ : can't have its name now : ?: '? IF S" ;" WAITW ELSE CURWORD WORD! _ THEN ; : ~DOER ENTRY lbldoes CALLi, [COMPILE] ~ ; \ Cross compilation program : XWRAP COREH XCURRENT lblhere PC2A T! HERESTART ?DUP NOT IF PC THEN lblhere PC2A 1+ 1+ T! ; : ['] WORD XFIND LITN ; IMMEDIATE : COMPILE [COMPILE] ['] S" ," XFIND T, ; IMMEDIATE : IF (?br)* T, HERE 1 ALLOT ; IMMEDIATE : ELSE (br)* T, 1 ALLOT [COMPILE] THEN HERE 1- ; IMMEDIATE : AGAIN (br)* T, HERE - C, ; IMMEDIATE : UNTIL (?br)* T, HERE - C, ; IMMEDIATE : NEXT (next)* T, HERE - C, ; IMMEDIATE : S" (br)* T, HERE 1 ALLOT HERE ," TUCK HERE -^ SWAP [COMPILE] THEN SWAP _xoff - LITN LITN ; IMMEDIATE : [COMPILE] WORD XFIND T, ; IMMEDIATE : IMMEDIATE XCURRENT _xoff + 1- DUP C@ $80 OR SWAP C! ; ':' ' _ 4 - C! \ give : its real name now 0 XSTART \ Core Forth words. See doc/cross. SYSVARS SYSVARS 12 CONSTS+ $00 IOERR $02 'CURRENT $04 'HERE $0a NL $0c LN< $0e 'EMIT $10 'KEY? $12 'CURWORD $16 '(wnf) $1c 'IN( $1e 'IN> $20 INBUF SYSVARS $02 + *VALUE CURRENT SYSVARS $04 + *VALUE HERE SYSVARS $0e + *ALIAS EMIT SYSVARS $10 + *ALIAS KEY? SYSVARS $1c + *VALUE IN( SYSVARS $1e + *VALUE IN> $40 CONSTANT LNSZ CODE NOOP ;CODE \ Core words, basic arithmetic and stack management ?: = - NOT ; ?: > SWAP < ; ?: 0< $7fff > ; ?: 0>= $8000 < ; ?: >= < NOT ; ?: <= > NOT ; ?: 1+ 1 + ; ?: 1- 1 - ; ?: 2DROP DROP DROP ; ?: 2DUP OVER OVER ; ?: NIP SWAP DROP ; ?: TUCK SWAP OVER ; ?: ROT> ROT ROT ; ?: =><= ( n l h -- f ) OVER - ROT> ( h n l ) - >= ; : / /MOD NIP ; : MOD /MOD DROP ; ?: <> ( n n -- l h ) 2DUP > IF SWAP THEN ; ?: MIN <> DROP ; ?: MAX <> NIP ; ?: -^ SWAP - ; \ Core words, bit shifting, A register, LEAVE VAL L|M +! ?: << 2 * ; ?: >> 2 / ; ?: <<8 $100 * ; ?: >>8 $100 / ; ?: RSHIFT ?DUP IF >R BEGIN >> NEXT THEN ; ?: LSHIFT ?DUP IF >R BEGIN << NEXT THEN ; ?: L|M DUP <<8 >>8 SWAP >>8 ; ?: +! ( n a -- ) TUCK @ + SWAP ! ; ?: A> [ 'A LITN ] @ ; ?: >A [ 'A LITN ] ! ; ?: A>R R> A> >R >R ; ?: R>A R> R> >A >R ; ?: A+ 1 [ 'A LITN ] +! ; ?: A- -1 [ 'A LITN ] +! ; ?: AC@ A> C@ ; ?: AC! A> C! ; : AC@+ AC@ A+ ; : AC!+ AC! A+ ; : LEAVE R> R~ 1 >R >R ; ?: TO 1 [ SYSVARS $18 + LITN ] C! ; \ Core words, C@+ ALLOT FILL IMMEDIATE , L, M, MOVE MOVE, .. ?: C@+ DUP 1+ SWAP C@ ; ?: C!+ TUCK C! 1+ ; : ALLOT 'HERE +! ; ?: FILL ( a u b -- ) \ *A* ROT> >R >A BEGIN DUP AC!+ NEXT DROP ; : ALLOT0 ( u -- ) HERE OVER 0 FILL ALLOT ; : IMMEDIATE CURRENT 1- DUP C@ $80 OR SWAP C! ; : , HERE ! 2 ALLOT ; : C, HERE C! 1 ALLOT ; : L, DUP C, >>8 C, ; : M, DUP >>8 C, C, ; ?: MOVE ( src dst u -- ) ?DUP IF >R >A BEGIN ( src ) C@+ AC!+ NEXT DROP THEN ; : MOVE, ( a u -- ) HERE OVER ALLOT SWAP MOVE ; \ Core words, [C]? CRC16 []= JMPi! CALLi! ?: JMPi! [ X' NOOP PC2A C@ ( jmp op ) LITN ] SWAP C!+ ! 3 ; ?: CALLi! [ X' MOVE, PC2A C@ ( call op ) LITN ] SWAP C!+ ! 3 ; ?: [C]? ( c a u -- i ) \ Guards A ?DUP NOT IF 2DROP -1 EXIT THEN A>R OVER >R >R >A ( c ) BEGIN DUP AC@+ = IF LEAVE THEN NEXT ( c ) A- AC@ = IF A> R> - ( i ) ELSE R~ -1 THEN R>A ; ?: []= ( a1 a2 u -- f ) \ Guards A ?DUP NOT IF 2DROP 1 EXIT THEN A>R >R >A ( a1 ) BEGIN AC@+ OVER C@ = NOT IF R~ R>A DROP 0 EXIT THEN 1+ NEXT DROP R>A 1 ; ?: CRC16 ( c n -- c ) <<8 XOR 8 >R BEGIN ( c ) DUP 0< IF << $1021 XOR ELSE << THEN NEXT ; \ Core words, STYPE SPC> NL> STACK? LITN : STYPE >R >A BEGIN AC@+ EMIT NEXT ; 5 CONSTS $04 EOT $08 BS $0a LF $0d CR $20 SPC : SPC> SPC EMIT ; : NL> NL @ L|M ?DUP IF EMIT THEN EMIT ; : STACK? SCNT 0< IF S" stack underflow" STYPE ABORT THEN ; : LITN DUP >>8 IF COMPILE (n) , ELSE COMPILE (b) C, THEN ; \ Core words, number formatting : FMTD ( n a -- sa sl ) \ *A* 6 + >A A>R DUP >R DUP 0< IF 0 -^ THEN BEGIN ( n ) 10 /MOD ( d q ) A- SWAP '0' + AC! ?DUP NOT UNTIL R> 0< IF A- '-' AC! THEN R> A> TUCK - ; PC TO L1 ," 0123456789abcdef" :~ ( n a 'len -- sa sl ) \ *A* C@ DUP >R DUP >R + >A BEGIN ( n ) 16 /MOD ( d q ) A- SWAP [ L1 LITN ] + C@ AC! NEXT DROP A> R> ; ~DOER FMTx 2 C, ~DOER FMTX 4 C, :~ ( n 'w -- sa sl ) @ A>R HERE SWAP EXECUTE STYPE R>A ; ~DOER . X' FMTD T, ~DOER .x X' FMTx T, ~DOER .X X' FMTX T, \ Core words, literal parsing :~ ( sl -- n? f ) \ parse unsigned decimal >R 0 BEGIN ( r ) 10 * AC@+ ( r c ) '0' - DUP 9 > IF 2DROP R~ 0 EXIT THEN + NEXT ( r ) 1 ; : PARSE ( sa sl -- n? f ) \ *A* OVER C@ ''' = IF ( sa sl ) 3 = IF 1+ DUP 1+ C@ ''' = IF C@ 1 EXIT THEN THEN DROP 0 EXIT THEN ( sa sl ) OVER C@ '$' = IF ( sa sl ) 1- >R 1+ >A 0 BEGIN ( r ) 16 * AC@+ ( r c ) $20 OR [ L1 LITN ] ( B216 ) $10 [C]? DUP 0< IF 2DROP R~ 0 EXIT THEN + NEXT ( r ) 1 EXIT THEN SWAP >A DUP 1 > AC@ '-' = AND IF ( sl ) A+ 1- ~ IF 0 -^ 1 ELSE 0 THEN ELSE ~ THEN ; \ Core words, input buffer : KEY BEGIN KEY? UNTIL ; : IN) IN( LNSZ + ; PC BS C, $7f ( DEL ) C, : BS? [ ( PC ) LITN ] 2 [C]? 0>= ; : WS? SPC <= ; \ type c into ptr inside INBUF. f=true if typing should stop : LNTYPE ( ptr c -- ptr+-1 f ) DUP BS? IF ( ptr c ) DROP DUP IN( > IF 1- BS EMIT THEN SPC> BS EMIT 0 ELSE ( ptr c ) \ non-BS DUP SPC < IF DROP DUP IN) OVER - 0 FILL 1 ELSE TUCK EMIT C!+ DUP IN) = THEN THEN ; \ Core words, input buffer, ," : RDLN ( -- ) \ Read 1 line in IN( S" ok" STYPE NL> IN( BEGIN KEY LNTYPE UNTIL DROP NL> ; : IN<? ( -- c-or-0 ) IN> IN) < IF IN> C@+ SWAP 'IN> ! ELSE 0 THEN ; : IN< ( -- c ) IN<? ?DUP NOT IF LN< @ EXECUTE IN( 'IN> ! SPC THEN ; : IN$ ['] RDLN LN< ! INBUF 'IN( ! IN) 'IN> ! ; : ," BEGIN IN< DUP '"' = IF DROP EXIT THEN C, AGAIN ; \ Core words, WORD parsing : TOWORD ( -- ) BEGIN IN< WS? NOT UNTIL ; : CURWORD ( -- sa sl ) 'CURWORD 1+ @ 'CURWORD C@ ; :~ ( f sa sl -- ) 'CURWORD C!+ TUCK ! 1+ 1+ C! ; : WORD ( -- sa sl ) 'CURWORD 3 + C@ IF CURWORD ELSE TOWORD IN> 1- 0 ( sa sl ) BEGIN 1+ IN<? WS? UNTIL THEN ( sa sl ) 2DUP 0 ROT> ~ ; : WORD! 1 ROT> ~ ; \ Core words, FIND (wnf) RUN1 INTERPRET nC, ?: FIND ( sa sl -- w? f ) \ Guards A A>R >R >A CURRENT BEGIN ( w R:sl ) DUP 1- C@ $7f AND ( wlen ) R@ = IF ( w ) DUP R@ - 3 - A> R@ ( w a1 a2 u ) []= IF ( w ) R~ 1 R>A EXIT THEN THEN 3 - ( prev field ) @ ?DUP NOT UNTIL R~ 0 R>A ( not found ) ; : (wnf) CURWORD STYPE S" word not found" STYPE ABORT ; : RUN1 ( -- ) \ interpret next word WORD PARSE NOT IF CURWORD FIND NOT IF '(wnf) @ THEN EXECUTE STACK? THEN ; : INTERPRET BEGIN RUN1 AGAIN ; : nC, ( n -- ) >R BEGIN RUN1 C, NEXT ; \ Core words, CODE '? ' TO FORGET : CODE WORD TUCK MOVE, ( len ) CURRENT , C, \ write prev value and size HERE 'CURRENT ! ; : '? WORD FIND DUP IF NIP THEN ; : ' WORD FIND NOT IF (wnf) THEN ; : FORGET ' DUP ( w w ) \ HERE must be at the end of prev's word, that is, at the \ beginning of w. DUP 1- C@ ( len ) $7f AND ( rm IMMEDIATE ) 3 + ( fixed header len ) - 'HERE ! ( w ) ( get prev addr ) 3 - @ 'CURRENT ! ; \ Core words, S= WAITW [IF] _bchk : S= ( sa1 sl1 sa2 sl2 -- f ) ROT OVER = IF ( same len, s2 s1 l ) []= ELSE DROP 2DROP 0 THEN ; : WAITW ( sa sl -- ) BEGIN 2DUP WORD S= UNTIL 2DROP ; : [IF] NOT IF S" [THEN]" WAITW THEN ; ALIAS NOOP [THEN] : _bchk DUP $80 + $ff > IF S" br ovfl" STYPE ABORT THEN ; \ Core words, DUMP .S : DUMP ( n a -- ) \ *A* >A 8 /MOD SWAP IF 1+ THEN >R BEGIN ':' EMIT A> DUP .x SPC> ( a ) 4 >R BEGIN AC@+ .x AC@+ .x SPC> NEXT ( a ) >A 8 >R BEGIN AC@+ DUP SPC - $5e > IF DROP '.' THEN EMIT NEXT NL> NEXT ; : PSDUMP SCNT NOT IF EXIT THEN SCNT >A BEGIN DUP .X SPC> >R SCNT NOT UNTIL BEGIN R> SCNT A> = UNTIL ; : .S ( -- ) S" SP " STYPE SCNT .x SPC> S" RS " STYPE RCNT .x SPC> S" -- " STYPE STACK? PSDUMP ; \ Core high, CREATE DOER DOES> CODE ALIAS VALUE : ;CODE [ lblnext LITN ] HERE JMPi! ALLOT ; : CREATE CODE [ lblcell LITN ] HERE CALLi! ALLOT ; : DOER CODE [ lbldoes LITN ] HERE CALLi! 1+ 1+ ALLOT ; : _ R> CURRENT 3 + ! ; \ Popping RS makes us EXIT from parent : DOES> COMPILE _ [ lblxt LITN ] HERE CALLi! ALLOT ; IMMEDIATE : ALIAS ' CODE HERE JMPi! ALLOT ; : VALUE CODE [ lblval LITN ] HERE CALLi! ALLOT , ; : VALUES >R BEGIN 0 VALUE NEXT ; : CONSTS >R BEGIN RUN1 VALUE NEXT ; \ Core high, BOOT \ :~ IN$ INTERPRET BYE ; \ '~ @ lblmain PC2A T! \ set jump in QUIT \ PC TO lblhere 4 ALLOT \ CURRENT, HERESTART \ : BOOT [ lblhere LITN ] 'CURRENT 4 MOVE \ ['] (emit) 'EMIT ! ['] (key?) 'KEY? ! ['] (wnf) '(wnf) ! \ 0 'CURWORD 3 + C! \ 0 IOERR ! $0d0a ( CR/LF ) NL ! \ 0 [ SYSVARS $18 ( TO? ) + LITN ] C! \ INIT S" Collapse OS" STYPE ABORT ; : boot S" Collapse OS" stype ; \ XCURRENT lblboot PC2A T! \ initial jump to BOOT \ Core high, : : XTCOMP [ lblxt LITN ] HERE CALLi! ALLOT BEGIN WORD S" ;" S= IF COMPILE EXIT EXIT THEN CURWORD PARSE IF LITN ELSE CURWORD FIND IF DUP 1- C@ $80 AND ( imm? ) IF EXECUTE ELSE , THEN ELSE '(wnf) @ EXECUTE THEN THEN AGAIN ; : : CODE XTCOMP ; \ Core high, IF..ELSE..THEN ( \ : IF ( -- a | a: br cell addr ) COMPILE (?br) HERE 1 ALLOT ( br cell allot ) ; IMMEDIATE : THEN ( a -- | a: br cell addr ) DUP HERE -^ _bchk SWAP ( a-H a ) C! ; IMMEDIATE : ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell ) COMPILE (br) 1 ALLOT [COMPILE] THEN HERE 1- ( push a. 1- for allot offset ) ; IMMEDIATE : ( S" )" WAITW ; IMMEDIATE : \ IN) 'IN> ! ; IMMEDIATE : S" COMPILE (br) HERE 1 ALLOT HERE ," TUCK HERE -^ SWAP [COMPILE] THEN SWAP LITN LITN ; IMMEDIATE \ Core high, .", ABORT", BEGIN..AGAIN..UNTIL, many others. : ." [COMPILE] S" COMPILE STYPE ; IMMEDIATE : ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE : BEGIN HERE ; IMMEDIATE : AGAIN COMPILE (br) HERE - _bchk C, ; IMMEDIATE : UNTIL COMPILE (?br) HERE - _bchk C, ; IMMEDIATE : NEXT COMPILE (next) HERE - _bchk C, ; IMMEDIATE : [ INTERPRET ; IMMEDIATE : ] R~ R~ ; \ INTERPRET+RUN1 : COMPILE ' LITN ['] , , ; IMMEDIATE : [COMPILE] ' , ; IMMEDIATE : ['] ' LITN ; IMMEDIATE \ BLK subsystem. See doc/blk BLK_MEM CONSTANT BLK( \ $400 + "\S " BLK_MEM $400 + CONSTANT BLK) \ Current blk pointer -1 means "invalid" BLK_MEM $403 + DUP CONSTANT 'BLK> *VALUE BLK> \ Whether buffer is dirty BLK_MEM $405 + CONSTANT BLKDTY BLK_MEM $407 + CONSTANT BLKIN> : BLK$ 0 BLKDTY ! -1 'BLK> ! S" \S " BLK) SWAP MOVE ; : BLK! ( -- ) BLK> BLK( (blk!) 0 BLKDTY ! ; : FLUSH BLKDTY @ IF BLK! THEN -1 'BLK> ! ; : BLK@ ( n -- ) DUP BLK> = IF DROP EXIT THEN FLUSH DUP 'BLK> ! BLK( (blk@) ; : BLK!! 1 BLKDTY ! ; : WIPE BLK( 1024 SPC FILL BLK!! ; : COPY ( src dst -- ) FLUSH SWAP BLK@ 'BLK> ! BLK! ; : LNLEN ( a -- len ) \ len based on last visible char in line 1- LNSZ >R BEGIN DUP R@ + C@ SPC > IF DROP R> EXIT THEN NEXT DROP 0 ; : EMITLN ( a -- ) \ emit LNSZ chars from a or stop at CR DUP LNLEN ?DUP IF >R >A BEGIN AC@+ EMIT NEXT ELSE DROP THEN NL> ; : LIST ( n -- ) \ print contents of BLK n BLK@ 16 >R 0 BEGIN ( n ) DUP 1+ DUP 10 < IF SPC> THEN . SPC> DUP LNSZ * BLK( + EMITLN 1+ NEXT DROP ; : INDEX ( b1 b2 -- ) \ print first line of blocks b1 through b2 OVER - 1+ >R BEGIN DUP . SPC> DUP BLK@ BLK( EMITLN 1+ NEXT DROP ; : \S BLK) 'IN( ! IN( 'IN> ! ; :~ ( -- ) IN) 'IN( ! ; : LOAD IN> BLKIN> ! [ '~ @ LITN ] LN< ! BLK@ BLK( 'IN( ! IN( 'IN> ! BEGIN RUN1 IN( BLK) = UNTIL IN$ BLKIN> @ 'IN> ! ; \ >R R> around LOAD is to avoid bad blocks messing PS up : LOADR OVER - 1+ >R BEGIN DUP . SPC> DUP >R LOAD R> 1+ NEXT DROP ; \ Application loader, to include in boot binary : ED 1 LOAD ( MOVE- ) 20 24 LOADR ; : VE 5 LOAD ( wordtbl ) ED 25 32 LOADR ; : ME 35 39 LOADR ; : ARCHM 301 LOAD ; : RXTX 10 15 LOADR ; : XCOMP 200 LOAD ; \ RX/TX subsystem. See doc/rxtx RXTX_MEM CONSTANT _emit RXTX_MEM 2 + CONSTANT _key : RX< BEGIN RX<? UNTIL ; : RX<< 0 BEGIN DROP RX<? NOT UNTIL ; : TX[ 'EMIT @ _emit ! ['] TX> 'EMIT ! ; : ]TX _emit @ 'EMIT ! ; : RX[ 'KEY? @ _key ! ['] RX<? 'KEY? ! ; : ]RX _key @ 'KEY? ! ; \ Media Spanning subsystem. see doc/mspan MSPAN_MEM CONSTANT MSPAN_DISK ?: DRVSEL ( drv -- ) DROP ; : prompt ( dsk -- ) DUP MSPAN_DISK C! S" Need disk " STYPE . SPC> KEY '0' - DUP 10 < IF DRVSEL ELSE DROP THEN ; : MSPAN$ 0 MSPAN_DISK C! ; : dskchk ( blk -- newblk ) A>R (msdsks) >A BEGIN AC@+ - DUP 0< AC@ NOT OR UNTIL A- AC@ + ( newblk ) A> (msdsks) - ( newblk dsk ) DUP MSPAN_DISK C@ = NOT IF prompt ELSE DROP THEN ( blk ) R>A ; :~ ( blk dest 'w -- ) ROT dskchk ROT> @ EXECUTE ; ~DOER (blk@) X' (ms@) T, ~DOER (blk!) X' (ms!) T, \ Grid subsystem. See doc/grid. GRID_MEM DUP CONSTANT 'XYPOS *VALUE XYPOS ?: CURSOR! 2DROP ; : XYPOS! COLS LINES * MOD DUP XYPOS CURSOR! 'XYPOS ! ; : AT-XY ( x y -- ) COLS * + XYPOS! ; ?: NEWLN ( oldln -- newln ) 1+ LINES MOD DUP COLS * ( pos ) COLS >R BEGIN SPC OVER CELL! 1+ NEXT DROP ; ?: CELLS! ( a pos u -- ) ?DUP IF >R SWAP >A BEGIN ( pos ) AC@+ OVER CELL! 1+ NEXT ELSE DROP THEN DROP ; : STYPEC ( sa sl pos -- ) SWAP CELLS! ; ?: FILLC ( pos n c ) SWAP >R SWAP BEGIN ( b pos ) 2DUP CELL! 1+ NEXT 2DROP ; : CLRSCR 0 COLS LINES * SPC FILLC 0 XYPOS! ; :~ ( line feed ) XYPOS COLS / NEWLN COLS * XYPOS! ; ?: (emit) DUP BS? IF DROP SPC XYPOS TUCK CELL! ( pos ) 1- XYPOS! EXIT THEN DUP CR = IF DROP SPC XYPOS CELL! ~ EXIT THEN DUP SPC < IF DROP EXIT THEN XYPOS CELL! XYPOS 1+ DUP COLS MOD IF XYPOS! ELSE DROP ~ THEN ; : GRID$ 0 'XYPOS ! ; PS/2 keyboard subsystem Provides (key?) from a driver providing the PS/2 protocol. That is, for a driver taking care of providing all key codes emanat- ing from a PS/2 keyboard, this subsystem takes care of mapping those keystrokes to ASCII characters. This code is designed to be cross-compiled and loaded with drivers. Requires PS2_MEM to be defined. Load range: 246-249 : PS2_SHIFT [ PS2_MEM LITN ] ; : PS2$ 0 PS2_SHIFT C! ; \ A list of the values associated with the $80 possible scan \ codes of the set 2 of the PS/2 keyboard specs. 0 means no \ value. That value is a character that can be read in (key?) \ No make code in the PS/2 set 2 reaches $80. \ TODO: I don't know why, but the key 2 is sent as $1f by 2 of \ my keyboards. Is it a timing problem on the ATtiny? CREATE PS2_CODES $80 nC, 0 0 0 0 0 0 0 0 0 0 0 0 0 9 '`' 0 0 0 0 0 0 'q' '1' 0 0 0 'z' 's' 'a' 'w' '2' '2' 0 'c' 'x' 'd' 'e' '4' '3' 0 0 32 'v' 'f' 't' 'r' '5' 0 0 'n' 'b' 'h' 'g' 'y' '6' 0 0 0 'm' 'j' 'u' '7' '8' 0 0 ',' 'k' 'i' 'o' '0' '9' 0 0 '.' '/' 'l' ';' 'p' '-' 0 0 0 ''' 0 '[' '=' 0 0 0 0 13 ']' 0 '\' 0 0 0 0 0 0 0 0 8 0 0 '1' 0 '4' '7' 0 0 0 '0' '.' '2' '5' '6' '8' 27 0 0 0 '3' 0 0 '9' 0 0 ( Same values, but shifted ) $80 nC, 0 0 0 0 0 0 0 0 0 0 0 0 0 9 '~' 0 0 0 0 0 0 'Q' '!' 0 0 0 'Z' 'S' 'A' 'W' '@' '@' 0 'C' 'X' 'D' 'E' '$' '#' 0 0 32 'V' 'F' 'T' 'R' '%' 0 0 'N' 'B' 'H' 'G' 'Y' '^' 0 0 0 'M' 'J' 'U' '&' '*' 0 0 '<' 'K' 'I' 'O' ')' '(' 0 0 '>' '?' 'L' ':' 'P' '_' 0 0 0 '"' 0 '{' '+' 0 0 0 0 13 '}' 0 '|' 0 0 0 0 0 0 0 0 8 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 27 0 0 0 0 0 0 0 0 0 : _shift? ( kc -- f ) DUP $12 = SWAP $59 = OR ; : (key?) ( -- c? f ) (ps2kc) DUP NOT IF EXIT THEN ( kc ) DUP $e0 ( extended ) = IF ( ignore ) DROP 0 EXIT THEN DUP $f0 ( break ) = IF DROP ( ) ( get next kc and see if it's a shift ) BEGIN (ps2kc) ?DUP UNTIL ( kc ) _shift? IF ( drop shift ) 0 PS2_SHIFT C! THEN ( whether we had a shift or not, we return the next ) 0 EXIT THEN DUP $7f > IF DROP 0 EXIT THEN DUP _shift? IF DROP 1 PS2_SHIFT C! 0 EXIT THEN ( ah, finally, we have a gentle run-of-the-mill KC ) PS2_CODES PS2_SHIFT C@ IF $80 + THEN + C@ ( c, maybe 0 ) ?DUP ( c? f ) ; \ SD Card subsystem Load range: B250-B258 SDC_MEM CONSTANT SDC_SDHC : _idle ( -- n ) $ff (spix) ; ( spix $ff until the response is something else than $ff for a maximum of 20 times. Returns $ff if no response. ) : _wait ( -- n ) 0 ( dummy ) 20 >R BEGIN DROP _idle DUP $ff = NOT IF LEAVE THEN NEXT ; ( adjust block for LBA for SD/SDHC ) : _badj ( arg1 arg2 -- arg1 arg2 ) SDC_SDHC @ IF 0 SWAP ELSE DUP 128 / SWAP <<8 << THEN ; ( The opposite of sdcWaitResp: we wait until response is $ff. After a successful read or write operation, the card will be busy for a while. We need to give it time before interacting with it again. Technically, we could continue processing on our side while the card it busy, and maybe we will one day, but at the moment, I'm having random write errors if I don't do this right after a write, so I prefer to stay cautious for now. ) : _ready ( -- ) BEGIN _idle $ff = UNTIL ; ( Computes n into crc c with polynomial $09 Note that the result is "left aligned", that is, that 8th bit to the "right" is insignificant (will be stop bit). ) : _crc7 ( c n -- c ) XOR 8 >R BEGIN ( c ) << ( c<<1 ) DUP >>8 IF ( MSB was set, apply polynomial ) <<8 >>8 $12 XOR ( $09 << 1, we apply CRC on high bits ) THEN NEXT ; ( send-and-crc7 ) : _s+crc ( n c -- c ) SWAP DUP (spix) DROP _crc7 ; ( cmd arg1 arg2 -- resp ) ( Sends a command to the SD card, along with arguments and specified CRC fields. (CRC is only needed in initial commands though). This does *not* handle CS. You have to select/deselect the card outside this routine. ) : _cmd _wait DROP ROT ( a1 a2 cmd ) 0 _s+crc ( a1 a2 crc ) ROT L|M ROT ( a2 h l crc ) _s+crc _s+crc ( a2 crc ) SWAP L|M ROT ( h l crc ) _s+crc _s+crc ( crc ) 1 OR ( ensure stop bit ) (spix) DROP ( send CRC ) _wait ( wait for a valid response... ) ; ( cmd arg1 arg2 -- r ) ( Send a command that expects a R1 response, handling CS. ) : SDCMDR1 [ SDC_DEVID LITN ] (spie) _cmd 0 (spie) ; ( cmd arg1 arg2 -- r arg1 arg2 ) ( Send a command that expects a R7 response, handling CS. A R7 is a R1 followed by 4 bytes. arg1 contains bytes 0:1, arg2 has 2:3 ) : SDCMDR7 [ SDC_DEVID LITN ] (spie) _cmd ( r ) _idle <<8 _idle + ( r arg1 ) _idle <<8 _idle + ( r arg1 arg2 ) 0 (spie) ; : _rdsdhc ( -- ) $7A ( CMD58 ) 0 0 SDCMDR7 DROP $4000 AND SDC_SDHC ! DROP ; : _err 0 (spie) S" SDerr" STYPE ABORT ; ( Tight definition ahead, pre-comment. Initialize a SD card. This should be called at least 1ms after the powering up of the card. We begin by waking up the SD card. After power up, a SD card has to receive at least 74 dummy clocks with CS and DI high. We send 80. Then send cmd0 for a maximum of 10 times, success is when we get $01. Then comes the CMD8. We send it with a $01aa argument and expect a $01aa argument back, along with a $01 R1 response. After that, we need to repeatedly run CMD55+CMD41 ($40000000) until the card goes out of idle mode, that is, when it stops sending us $01 response and send us $00 instead. Any other response means that initialization failed. ) : SDC$ 10 >R BEGIN _idle DROP NEXT 0 ( dummy ) 10 >R BEGIN ( r ) DROP $40 0 0 SDCMDR1 ( CMD0 ) 1 = DUP IF LEAVE THEN NEXT NOT IF _err THEN $48 0 $1aa ( CMD8 ) SDCMDR7 ( r arg1 arg2 ) ( expected 1 0 $1aa ) $1aa = ROT ( arg1 f r ) 1 = AND SWAP ( f&f arg1 ) NOT ( 0 expected ) AND ( f&f&f ) NOT IF _err THEN BEGIN $77 0 0 SDCMDR1 ( CMD55 ) 1 = NOT IF _err THEN $69 $4000 0 SDCMDR1 ( CMD41 ) DUP 1 > IF _err THEN NOT UNTIL _rdsdhc ; ( out of idle mode, success! ) :~ ( dstaddr blkno -- ) [ SDC_DEVID LITN ] (spie) $51 ( CMD17 ) SWAP _badj ( a cmd arg1 arg2 ) _cmd IF _err THEN _wait $fe = NOT IF _err THEN >A 512 >R 0 BEGIN ( crc1 ) _idle ( crc1 b ) DUP AC!+ ( crc1 b ) CRC16 NEXT ( crc1 ) _idle <<8 _idle + ( crc1 crc2 ) _wait DROP 0 (spie) = NOT IF _err THEN ; : SDC@ ( blkno blk( -- ) SWAP << ( 2x ) 2DUP ( a b a b ) ~ ( a b ) 1+ SWAP 512 + SWAP ~ ; :~ ( srcaddr blkno -- ) [ SDC_DEVID LITN ] (spie) $58 ( CMD24 ) SWAP _badj ( a cmd arg1 arg2 ) _cmd IF _err THEN _idle DROP $fe (spix) DROP >A 512 >R 0 BEGIN ( crc ) AC@+ ( crc b ) DUP (spix) DROP CRC16 NEXT ( crc ) DUP >>8 ( crc msb ) (spix) DROP (spix) DROP _wait $1f AND 5 = NOT IF _err THEN _ready 0 (spie) ; : SDC! ( blkno blk( -- ) SWAP << ( 2x ) 2DUP ( a b a b ) ~ ( a b ) 1+ SWAP 512 + SWAP ~ ; Fonts Fonts are kept in "source" form in the following blocks and then compiled to binary bitmasks by the following code. In source form, fonts are a simple sequence of '.' and 'X'. '.' means empty, 'X' means filled. Glyphs are entered one after the other, starting at $21 and ending at $7e. To be space efficient in blocks, we align glyphs horizontally in the blocks to fit as many character as we can. For example, a 5x7 font would mean that we would have 12x2 glyphs per block. 261 Font compiler 265 3x5 font 267 5x7 font 271 7x7 font \ Converts "dot-X" fonts to binary "glyph rows". One byte for \ each row. In a 5x7 font, each glyph thus use 7 bytes. \ Resulting bytes are aligned to the left of the byte. \ Therefore, for a 5-bit wide char, "X.X.X" translates to \ 10101000. Left-aligned bytes are easier to work with when \ compositing glyphs. 2 VALUES _w _h : _g ( given a top-left of dot-X in BLK(, spit H bin lines ) DUP >A _h >R BEGIN _w >R 0 BEGIN ( a r ) << AC@+ 'X' = IF 1+ THEN NEXT 8 _w - LSHIFT C, 64 + DUP >A NEXT DROP ; : _l ( a u -- a, spit a line of u glyphs ) >R DUP BEGIN ( a ) DUP _g _w + NEXT DROP ; : CPFNT3x5 3 TO _w 5 TO _h _h ALLOT0 ( space char ) 265 BLK@ BLK( 21 _l 320 + 21 _l 320 + 21 _l DROP ( 63 ) 266 BLK@ BLK( 21 _l 320 + 10 _l DROP ( 94! ) ; : CPFNT5x7 5 TO _w 7 TO _h _h ALLOT0 ( space char ) 3 >R 267 BEGIN ( b ) DUP BLK@ BLK( 12 _l 448 + 12 _l DROP 1+ NEXT ( 72 ) ( 270 ) BLK@ BLK( 12 _l 448 + 10 _l DROP ( 94! ) ; : CPFNT7x7 7 TO _w 7 TO _h _h ALLOT0 ( space char ) 5 >R 271 BEGIN ( b ) DUP BLK@ BLK( 9 _l 448 + 9 _l DROP 1+ NEXT ( 90 ) ( 276 ) BLK@ BLK( 4 _l DROP ( 94! ) ; .X.X.XX.X.XXX...X..X...XX...X...............X.X..X.XX.XX.X.XXXX .X.X.XXXXXX...XX.X.X..X..X.XXX.X............XX.XXX...X..XX.XX.. .X........XX.X..X.....X..X..X.XXX...XXX....X.X.X.X..X.XX.XXXXX. ......XXXXX.X..X.X....X..X.X.X.X..X.......X..X.X.X.X....X..X..X .X....X.X.X...X.XX.....XX........X......X.X...X.XXXXXXXX...XXX. .XXXXXXXXXXX........X...X..XX..X..X.XX..XXXX.XXXXXX.XXX.XXXXXXX X....XX.XX.X.X..X..X.XXX.X...XXXXX.XX.XX..X.XX..X..X..X.X.X...X XXX.X.XXXXXX......X.......X.X.XXXXXXXX.X..X.XXX.XX.X.XXXX.X...X X.XX..X.X..X.X..X..X.XXX.X....X..X.XX.XX..X.XX..X..X.XX.X.X...X XXXX..XXXXX....X....X...X...X..XXX.XXX..XXXX.XXXX...XXX.XXXXXX. X.XX..X.XXX.XXXXX.XXXXX..XXXXXX.XX.XX.XX.XX.XXXXXXXX..XXX.X.... XX.X..XXXX.XX.XX.XX.XX.XX...X.X.XX.XX.XX.XX.X..XX..X....XX.X... X..X..XXXX.XX.XXX.X.XXX..X..X.X.XX.XXXX.X..X..X.X...X...X...... XX.X..X.XX.XX.XX..XXXX.X..X.X.X.XX.XXXXX.X.X.X..X....X..X...... X.XXXXX.XX.XXXXX...XXX.XXX..X.XXX.X.X.XX.X.X.XXXXXX..XXXX...XXX !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_ X.....X.......X....XX...X...X...XX..XX.......................X. .X.XX.X...XX..X.X.X...X.X........X.X.X.X.XXX..X.XX..XX.XX.XXXXX .....XXX.X...XXX.XXX.X.XXX..X...XXX..X.XXXX.XX.XX.XX.XX..XX..X. ...XXXX.XX..X.XXX.X...XXX.X.X...XX.X.X.X.XX.XX.XXX..XXX....X.X. ...XXXXX..XX.XX.XXX..XX.X.X.X.XX.X.X.XXX.XX.X.X.X....XX..XX..XX ...................XX.X.XX..................................... X.XX.XX.XX.XX.XXXX.X..X..X..XX X.XX.XX.X.X..X..XXX...X...XXX. X.XX.XXXX.X..X.XX..X..X..X.... XXX.X.X.XX.X.X.XXX.XX.X.XX.... `abcdefghijklmnopqrstuvwxyz{|}~ ..X...X.X........X..............X....X....X................. ..X...X.X..X.X..XXXXX...X.XX....X...X......X.X.X.X..X....... ..X.......XXXXXX.......X.X..X......X........X.XXX...X....... ..X........X.X..XXX...X...XX.......X........XXXXXXXXXXX..... ..........XXXXX....X.X....XX.X.....X........X.XXX...X....... ..X........X.X.XXXX.X...XX..X.......X......X.X.X.X..X.....X. ..X..............X.......XXX.X.......X....X..............X.. ................XXX...XX..XXX..XXX...XX.XXXXX.XXX.XXXXX.XXX. ..............XX...X.X.X.X...XX...X.X.X.X....X........XX...X .............X.X..XX...X.....X....XX..X.XXXX.X........XX...X XXXXX.......X..X.X.X...X....X...XX.XXXXX....XXXXX....X..XXX. ...........X...XX..X...X...X......X...X.....XX...X..X..X...X ......XX..X....X...X...X..X...X...X...X.X...XX...X.X...X...X ......XX........XXX..XXXXXXXXX.XXX....X..XXX..XXX.X.....XXX. !"#$%&'()*+,-./012345678 .XXX...............X.....X.....XXX..XXX..XXX.XXXX..XXX.XXXX. X...X..X....X....XX.......XX..X...XX...XX...XX...XX...XX...X X...X..X....X...XX..XXXXX..XX.....XX..XXX...XX...XX....X...X .XXX...........X.............X...X.X..XXXXXXXXXXX.X....X...X ....X..X....X...XX..XXXXX..XX...X..X....X...XX...XX....X...X ....X..X...X.....XX.......XX.......X...XX...XX...XX...XX...X .XXX...............X.....X......X...XXX.X...XXXXX..XXX.XXXX. XXXXXXXXXX.XXX.X...X.XXX....XXX..X.X....X...XX...X.XXX.XXXX. X....X....X...XX...X..X......XX.X..X....XX.XXXX..XX...XX...X X....X....X....X...X..X......XXX...X....X.X.XXX..XX...XX...X XXXX.XXXX.X..XXXXXXX..X......XX....X....X...XX.X.XX...XXXXX. X....X....X...XX...X..X......XXX...X....X...XX..XXX...XX.... X....X....X...XX...X..X..X...XX.X..X....X...XX..XXX...XX.... XXXXXX.....XXX.X...X.XXX..XXX.X..X.XXXXXX...XX...X.XXX.X.... 9:;<=>?@ABCDEFGHIJKLMNOP .XXX.XXXX..XXX.XXXXXX...XX...XX...XX...XX...XXXXXXXXX....... X...XX...XX...X..X..X...XX...XX...XX...XX...XX...XX....X.... X...XX...XX......X..X...XX...XX...X.X.X..X.X....X.X.....X... X...XXXXX..XXX...X..X...XX...XX...X..X....X....X..X......X.. X.X.XX.X......X..X..X...XX...XX.X.X.X.X...X...X...X.......X. X..XXX..X.X...X..X..X...X.X.X.X.X.XX...X..X..X...XX........X .XXXXX...X.XXX...X...XXX...X...X.X.X...X..X..XXXXXXXX....... ..XXX..X.........X.......................................... ....X.X.X.........X......................................... ....XX...X...........XXX.X.....XXX.....X.XXX..XX....XXXX.... ....X...................XX....X...X....XX...XX..X..X..XX.... ....X................XXXXXXX..X......XXXXXXXXX......XXXXXX.. ....X...............X...XX..X.X...X.X..XX....XXX......XX..X. ..XXX.....XXXXX......XXXXXXX...XXX...XXX.XXXXX......XX.X..X. QRSTUVWXYZ[\]^_`abcdefgh ............................................................ ............................................................ ..X......XX..X..XX...X.X.XXX...XXX.XXX....XXXX.XX..XXX..X... ..........X.X....X..X.X.XX..X.X...XX..X..X..XXX...X....XXX.. ..X......XXX.....X..X...XX...XX...XXXX....XXXX.....XXX..X... ..X...X..XX.X....X..X...XX...XX...XX........XX........X.X... ..X....XX.X..X...XX.X...XX...X.XXX.X........XX.....XXX...XX. ................................XX...X...XX....... ...............................X.....X.....X...... X...XX...XX...XX...XX...XXXXXX.X.....X.....X..X.X. X...XX...XX...X.X.X..X.X....X.X......X......XX.X.. X...XX...XX...X..X....X....X...X.....X.....X...... X...X.X.X.X.X.X.X.X..X....X....X.....X.....X...... .XXX...X...X.X.X...XX....XXXXX..XX...X...XX....... ijklmnopqrstuvwxyz{|}~ ..XX....XX.XX..XX.XX....XX..XX......XXX......XX.....XX...XX.... ..XX....XX.XX..XX.XX..XXXXXXXX..XX.XX.XX....XX.....XX.....XX... ..XX....XX.XX.XXXXXXXXX.X......XX..XX.XX...XX.....XX.......XX.. ..XX...........XX.XX..XXXXX...XX....XXX...........XX.......XX.. ..XX..........XXXXXXX...X.XX.XX....XX.XX.X........XX.......XX.. ...............XX.XX.XXXXXX.XX..XX.XX..XX..........XX.....XX... ..XX...........XX.XX...XX.......XX..XXX.XX..........XX...XX.... ...........................................XXXX....XX....XXXX.. ..XX.....XX............................XX.XX..XX..XXX...XX..XX. XXXXXX...XX...........................XX..XX.XXX...XX.......XX. .XXXX..XXXXXX........XXXXXX..........XX...XXXXXX...XX......XX.. XXXXXX...XX.........................XX....XXX.XX...XX.....XX... ..XX.....XX.....XX............XX...XX.....XX..XX...XX....XX.... ...............XX.............XX...........XXXX..XXXXXX.XXXXXX. !"#$%&'()*+,-./012 .XXXX.....XX..XXXXXX...XXX..XXXXXX..XXXX...XXXX................ XX..XX...XXX..XX......XX........XX.XX..XX.XX..XX............... ....XX..XXXX..XXXXX..XX........XX..XX..XX.XX..XX...XX.....XX... ..XXX..XX.XX......XX.XXXXX....XX....XXXX...XXXXX...XX.....XX... ....XX.XXXXXX.....XX.XX..XX..XX....XX..XX.....XX............... XX..XX....XX..XX..XX.XX..XX..XX....XX..XX....XX....XX.....XX... .XXXX.....XX...XXXX...XXXX...XX.....XXXX...XXX.....XX....XX.... ...XX.........XX......XXXX...XXXX...XXXX..XXXXX...XXXX..XXXX... ..XX...........XX....XX..XX.XX..XX.XX..XX.XX..XX.XX..XX.XX.XX.. .XX....XXXXXX...XX......XX..XX.XXX.XX..XX.XX..XX.XX.....XX..XX. XX...............XX....XX...XX.X.X.XXXXXX.XXXXX..XX.....XX..XX. .XX....XXXXXX...XX.....XX...XX.XXX.XX..XX.XX..XX.XX.....XX..XX. ..XX...........XX...........XX.....XX..XX.XX..XX.XX..XX.XX.XX.. ...XX.........XX.......XX....XXXX..XX..XX.XXXXX...XXXX..XXXX... 3456789:;<=>?@ABCD XXXXXX.XXXXXX..XXXX..XX..XX.XXXXXX..XXXXX.XX..XX.XX.....XX...XX XX.....XX.....XX..XX.XX..XX...XX......XX..XX.XX..XX.....XXX.XXX XX.....XX.....XX.....XX..XX...XX......XX..XXXX...XX.....XXXXXXX XXXXX..XXXXX..XX.XXX.XXXXXX...XX......XX..XXX....XX.....XX.X.XX XX.....XX.....XX..XX.XX..XX...XX......XX..XXXX...XX.....XX.X.XX XX.....XX.....XX..XX.XX..XX...XX...XX.XX..XX.XX..XX.....XX...XX XXXXXX.XX......XXXX..XX..XX.XXXXXX..XXX...XX..XX.XXXXXX.XX...XX XX..XX..XXXX..XXXXX...XXXX..XXXXX...XXXX..XXXXXX.XX..XX.XX..XX. XX..XX.XX..XX.XX..XX.XX..XX.XX..XX.XX..XX...XX...XX..XX.XX..XX. XXX.XX.XX..XX.XX..XX.XX..XX.XX..XX.XX.......XX...XX..XX.XX..XX. XXXXXX.XX..XX.XXXXX..XX..XX.XXXXX...XXXX....XX...XX..XX.XX..XX. XX.XXX.XX..XX.XX.....XX.X.X.XX.XX......XX...XX...XX..XX.XX..XX. XX..XX.XX..XX.XX.....XX.XX..XX..XX.XX..XX...XX...XX..XX..XXXX.. XX..XX..XXXX..XX......XX.XX.XX..XX..XXXX....XX....XXXX....XX... EFGHIJKLMNOPQRSTUVWXYZ[\]^_ XX...XXXX..XX.XX..XX.XXXXXX.XXXXX.........XXXXX....XX.......... XX...XXXX..XX.XX..XX.....XX.XX.....XX........XX...XXXX......... XX.X.XX.XXXX..XX..XX....XX..XX......XX.......XX..XX..XX........ XX.X.XX..XX....XXXX....XX...XX.......XX......XX..X....X........ XXXXXXX.XXXX....XX....XX....XX........XX.....XX................ XXX.XXXXX..XX...XX...XX.....XX.........XX....XX................ XX...XXXX..XX...XX...XXXXXX.XXXXX.........XXXXX.........XXXXXXX .XX...........XX................XX..........XXX.........XX..... ..XX..........XX................XX.........XX.....XXXX..XX..... ...XX...XXXX..XXXXX...XXXX...XXXXX..XXXX...XX....XX..XX.XXXXX.. ...........XX.XX..XX.XX..XX.XX..XX.XX..XX.XXXXX..XX..XX.XX..XX. ........XXXXX.XX..XX.XX.....XX..XX.XXXXXX..XX.....XXXXX.XX..XX. .......XX..XX.XX..XX.XX..XX.XX..XX.XX......XX........XX.XX..XX. ........XXXXX.XXXXX...XXXX...XXXXX..XXXX...XX.....XXX...XX..XX. WXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ ..XX.....XX...XX......XXX...................................... ..............XX.......XX...................................... .XXX....XXX...XX..XX...XX....XX.XX.XXXXX...XXXX..XXXXX...XXXXX. ..XX.....XX...XX.XX....XX...XXXXXXXXX..XX.XX..XX.XX..XX.XX..XX. ..XX.....XX...XXXX.....XX...XX.X.XXXX..XX.XX..XX.XX..XX.XX..XX. ..XX.....XX...XX.XX....XX...XX.X.XXXX..XX.XX..XX.XXXXX...XXXXX. .XXXX..XX.....XX..XX..XXXX..XX...XXXX..XX..XXXX..XX.........XX. ...............XX.............................................. ...............XX.............................................. XX.XX...XXXXX.XXXXX..XX..XX.XX..XX.XX...XXXX..XX.XX..XX.XXXXXX. XXX.XX.XX......XX....XX..XX.XX..XX.XX.X.XX.XXXX..XX..XX....XX.. XX......XXXX...XX....XX..XX.XX..XX.XX.X.XX..XX...XX..XX...XX... XX.........XX..XX....XX..XX..XXXX..XXXXXXX.XXXX...XXXXX..XX.... XX.....XXXXX....XXX...XXXXX...XX....XX.XX.XX..XX.....XX.XXXXXX. ijklmnopqrstuvwxyz{|}~ ...XX....XX...XX......XX...X ..XX.....XX....XX....XX.X.XX ..XX.....XX....XX....X...XX. XXX......XX.....XXX......... ..XX.....XX....XX........... ..XX.....XX....XX........... ...XX....XX...XX............ {|}~ \ Automated tests. "1 LOAD 290 296 LOADR" to run. \ "#" means "assert". We ABORT on failure. : fail SPC> ABORT" failed" ; : # IF SPC> ." pass" NL> ELSE fail THEN ; : #eq 2DUP SWAP . SPC> '=' EMIT SPC> . '?' EMIT = # ; \ Arithmetics 48 13 + 61 #eq 48 13 - 35 #eq 48 13 * 624 #eq 48 13 / 3 #eq 48 13 MOD 9 #eq 5 3 LSHIFT 40 #eq 155 5 RSHIFT 4 #eq \ Comparisons $22 $8065 < # -1 0 > # -1 0< # \ Memory 42 C, 43 C, 44 C, HERE 3 - HERE 3 MOVE HERE C@ 42 #eq HERE 1+ C@ 43 #eq HERE 2 + C@ 44 #eq HERE HERE 1+ 3 MOVE ( demonstrate MOVE's problem ) HERE 1+ C@ 42 #eq HERE 2 + C@ 42 #eq HERE 3 + C@ 42 #eq HERE 3 - HERE 3 MOVE HERE HERE 1+ 3 MOVE- ( see? better ) HERE 1+ C@ 42 #eq HERE 2 + C@ 43 #eq HERE 3 + C@ 44 #eq HERE ( ref ) HERE 3 - 3 MOVE, ( ref ) HERE 3 - #eq HERE 3 - C@ 42 #eq HERE 2 - C@ 43 #eq HERE 1- C@ 44 #eq \ Parse 'b' $62 #eq \ Stack 42 43 44 ROT 42 #eq 44 #eq 43 #eq 42 43 44 ROT> 43 #eq 42 #eq 44 #eq \ CRC $0000 $00 CRC16 $0000 #eq $0000 $01 CRC16 $1021 #eq $5678 $34 CRC16 $34e4 #eq
+\ No newline at end of file
diff --git a/fs/cos/cos.fs b/fs/cos/cos.fs
@@ -1,8 +1,34 @@
\ Collapse OS compatibility layer
+\ Load this in a separate context because this messes with most core words
\ Work in progress...
?f<< /lib/block.fs
-0 p" /cos/core.blk" Path :open to blkfile
+p" /cos/core.blk" Path :open const corefile
+p" /cos/z80.blk" Path :open const archfile
+alias execute _execute
+alias load _load
+
+\ From here on, we align ourselves to 64K, because all addresses coming from
+\ COS are in the 64K range. That's our world now. Whenever we deal with an
+\ address, we need to or-in the upper 16-bit in it to match to a host addr.
+
+here $10000 mod if $10000 -^ allot then
+here $ffff0000 and const PREFIX
+: prefix ( a -- a ) PREFIX or ;
+
+: xtcomp [compile] ] ;
+: load dup 300 < if corefile else 300 - archfile then to blkfile _load ;
+: loadr 1+ for2 i . spc> i load next ;
+: @ prefix 16b w@ ;
+: ! prefix 16b w! ;
+: execute prefix _execute ;
+301 load
226 load
boot
+z80a
+2 wordtbl foo
+:w ." foo!" ;
+:w ." bar!" ;
+foo 0 wexec
+foo 1 wexec
diff --git a/fs/cos/z80.blk b/fs/cos/z80.blk
@@ -0,0 +1 @@
+Z80 MASTER INDEX 301 Z80 boot code 310 Z80 HAL 320 Z80 assembler 330 AT28 EEPROM 332 SPI relay 335 TMS9918 340 MC6850 driver 345 Zilog SIO driver 350 Sega Master System VDP 355 SMS PAD 360 SMS KBD 367 SMS SPI relay 368 SMS Ports 370 TI-84+ LCD 375 TI-84+ Keyboard 380 TRS-80 4P drivers 395 Dan SBC drivers 410 Virgil's workspace \ Z80 port's Macros and constants. See doc/code/z80.txt : z80a 5 load ( wordtbl ) ; \ 320 329 LOADR 7 LOAD ( Flow words : z80c 302 314 loadr ; : trs804pm 380 load ; \ see comment at TICKS' definition \ 7.373MHz target: 737t. outer: 37t inner: 16t \ tickfactor = (737 - 37) / 16 44 value tickfactor 0 value L4 \ we need a 4th temp label in core routines \ Z80 port, core routines FJR jr, TO L1 $10 OALLOT LSET lblxt ( RST 10 ) IX inc, IX inc, 0 ix+) E ld, 1 ix+) D ld, HL pop, ldDE(HL), HL inc, DE HL ex, jp(HL), \ 17 bytes $28 OALLOT LSET lblcell ( RST 28 ) HL pop, BC push, HL>BC, FJR jr, TO L2 ( next ) $30 OALLOT LSET lblval ( RST 30 ) A SYSVARS $18 + m) ld, A A or, FJR CZ jrc, TO L3 ( read ) FJR jr, TO L4 ( write ) \ 8 bytes 0 jp, ( RST 38 ) $66 OALLOT retn, L1 FMARK di, SP PS_ADDR i) ld, IX RS_ADDR i) ld, 0 jp, PC 2 - TO lblbootL3 FMARK ( val read ) HL pop, BC push, ldBC(HL), \ to lblnext LSET lblnext L2 FMARK DE HL ex, LSET L1 ( EXIT ) ldDE(HL), HL inc, DE HL ex, jp(HL), L4 FMARK ( val write ) clrA, SYSVARS $18 + m) A ld, HL pop, (HL) C ld, HL inc, (HL) B ld, BC pop, lblnext BR jr, \ Z80 port, lbldoes EXIT QUIT ABORT BYE RCNT SCNT LSET lbldoes HL pop, BC push, HL>BC, BC inc, BC inc, ldHL(HL), jp(HL), CODE EXIT \ put new IP in HL instead of DE for speed L 0 ix+) ld, H 1 ix+) ld, IX dec, IX dec, L1 jp, CODE QUIT LSET L1 \ used in ABORT IX RS_ADDR i) ld, 0 jp, PC 2 - TO lblmain CODE ABORT SP PS_ADDR i) ld, L1 BR jr, CODE BYE halt, CODE RCNT BC push, IX push, HL pop, BC RS_ADDR i) ld, BC subHL, HL>BC, ;CODE CODE SCNT HL 0 i) ld, HL SP add, BC push, HL>BC, HL PS_ADDR i) ld, BC subHL, HL>BC, ;CODE \ Z80 port, TICKS \ The word below is designed to wait the proper 100us per tick \ at 500kHz when tickfactor is 1. If the CPU runs faster, \ tickfactor has to be adjusted accordingly. "t" in comments \ below means "T-cycle", which at 500kHz is worth 2us. CODE TICKS \ we pre-dec to compensate for initialization BEGIN, BC dec, ( 6t ) IFZ, ( 12t ) BC pop, ;CODE THEN, A tickfactor i) ld, ( 7t ) BEGIN, A dec, ( 4t ) BR CNZ jrc, ( 12t ) BR jr, ( 12t ) ( outer: 37t inner: 16t ) \ Z80 port, PC! PC@ []= [C]? (im1) CODE PC! HL pop, (C) L out, BC pop, ;CODE CODE PC@ C (C) in, B 0 i) ld, ;CODE CODE []= BC push, exx, ( protect DE ) BC pop, DE pop, HL pop, LSET L1 ( loop ) A (DE) ld, DE inc, cpi, IFNZ, exx, BC 0 i) ld, ;CODE THEN, L1 CPE jpc, ( BC not zero? loop ) exx, BC 1 i) ld, ;CODE CODE [C]? BCZ, IFZ, BC dec, HL pop, HL pop, ;CODE THEN, BC push, exx, BC pop, HL pop, DE pop, A E ld, D H ld, E L ld, \ HL=a DE=a BC=u A=c cpir, IFZ, DE subHL, HL dec, ELSE, HL -1 i) ld, THEN, HL push, exx, BC pop, ;CODE CODE (im1) im1, ei, ;CODE \ Z80 port, /MOD * CODE * HL pop, DE push, DE HL ex, ( DE * BC -> HL ) HL 0 i) ld, A $10 i) ld, BEGIN, HL HL add, E rl, D rl, IFC, HL BC add, THEN, A dec, BR CNZ jrc, HL>BC, DE pop, ;CODE \ Divides AC by DE. quotient in AC remainder in HL CODE /MOD BC>HL, BC pop, DE push, DE HL ex, A B ld, B 16 i) ld, HL 0 i) ld, BEGIN, scf, C rl, rla, HL HL adc, HL DE sbc, IFC, HL DE add, C dec, THEN, BR djnz, DE pop, HL push, B A ld, ;CODE \ Z80 port, FIND CODE FIND ( sa sl -- w? f ) HL pop, HL BC add, \ HL points to after last char of s 'N m) HL ld, HL SYSVARS $02 ( CURRENT ) + m) ld, BEGIN, HL dec, A (HL) ld, A $7f i) and, ( imm ) A C cp, IFZ, HL push, DE push, BC push, DE 'N m) ld, HL dec, HL dec, HL dec, \ Skip prev field LSET L1 ( loop ) DE dec, A (DE) ld, cpd, IFZ, TO L2 ( break! ) L1 CPE jpc, ( BC not zero? loop ) L2 FMARK BC pop, DE pop, HL pop, THEN, IFZ, ( match ) HL inc, HL push, BC 1 i) ld, ;CODE THEN, \ no match, go to prev and continue HL dec, A (HL) ld, HL dec, L (HL) ld, H A ld, A L or, IFZ, ( end of dict ) BC 0 i) ld, ;CODE THEN, BR jr, \ Z80 port, (b) (n) (br) (?br) (next) CODE (b) ( -- c ) BC push, A (DE) ld, A>BC, DE inc, ;CODE CODE (n) ( -- n ) BC push, DE HL ex, ldBC(HL), HL inc, DE HL ex, ;CODE CODE (br) LSET L1 ( used in ?br and next ) A (DE) ld, ( sign extend A into HL ) L A ld, A A add, ( sign in carry ) A A sbc, ( FF if neg ) H A ld, HL DE add, ( HL --> new IP ) DE HL ex, ;CODE CODE (?br) BCZ, BC pop, L1 BR CZ jrc, DE inc, ;CODE CODE (next) 0 ix+) dec, IFNZ, A $ff i) ld, A 0 ix+) cp, IFZ, 1 ix+) dec, THEN, L1 BR jr, THEN, A A xor, A 1 ix+) cp, L1 BR CNZ jrc, IX dec, IX dec, DE inc, ;CODE \ Z80 port, >R I C@ @ C! ! 1+ 1- + - CODE >R IX inc, IX inc, 0 ix+) C ld, 1 ix+) B ld, BC pop, ;CODE CODE R@ BC push, C 0 ix+) ld, B 1 ix+) ld, ;CODE CODE R~ IX dec, IX dec, ;CODE CODE R> BC push, C 0 ix+) ld, B 1 ix+) ld, IX dec, IX dec, ;CODE CODE C@ A (BC) ld, A>BC, ;CODE CODE @ BC>HL, ldBC(HL), ;CODE CODE C! BC>HL, BC pop, (HL) C ld, BC pop, ;CODE CODE ! BC>HL, BC pop, (HL) C ld, HL inc, (HL) B ld, BC pop, ;CODE CODE 1+ BC inc, ;CODE CODE 1- BC dec, ;CODE CODE + HL pop, HL BC add, HL>BC, ;CODE CODE - HL pop, BC subHL, HL>BC, ;CODE \ Z80 port, AND OR XOR >> << >>8 <<8 CODE AND HL pop, A C ld, A L and, C A ld, A B ld, A H and, B A ld, ;CODE CODE OR HL pop, A C ld, A L or, C A ld, A B ld, A H or, B A ld, ;CODE CODE XOR HL pop, A C ld, A L xor, C A ld, A B ld, A H xor, B A ld, ;CODE CODE NOT BCZ, BC 0 i) ld, IFZ, C inc, THEN, ;CODE CODE >> B srl, C rr, ;CODE CODE << C sla, B rl, ;CODE CODE >>8 C B ld, B 0 i) ld, ;CODE CODE <<8 B C ld, C 0 i) ld, ;CODE \ Z80 port, ROT ROT> DUP DROP SWAP OVER EXECUTE CODE ROT ( a b c -- b c a ) ( BC=c ) HL pop, ( b ) (SP) HL ex, ( a<>b ) BC push, ( c ) HL>BC, ;CODECODE ROT> ( a b c -- c a b ) ( BC=c ) BC>HL, BC pop, ( b ) (SP) HL ex, ( a<>c ) HL push, ;CODE CODE DUP ( a -- a a ) LSET L1 BC push, ;CODE CODE ?DUP BCZ, L1 BR CNZ jrc, ;CODE CODE DROP ( a -- ) BC pop, ;CODE CODE SWAP ( a b -- b a ) HL pop, BC push, HL>BC, ;CODE CODE OVER ( a b -- a b a ) HL pop, HL push, BC push, HL>BC, ;CODE CODE EXECUTE BC>HL, BC pop, jp(HL), \ Z80 port, JMPi! CALLi! CODE JMPi! ( pc a -- len ) BC>HL, BC pop, A $c3 i) ld, LSET L1 (HL) A ld, HL inc, (HL) C ld, HL inc, (HL) B ld, BC 3 i) ld, ;CODE CODE CALLi! ( pc a -- len ) BC>HL, BC pop, A B ld, A A or, IFZ, A C ld, A $c7 i) and, IFZ, \ RST A C ld, A $c7 i) or, (HL) A ld, BC 1 i) ld, ;CODE THEN, THEN, ( not RST ) A $cd i) ld, L1 BR jr, \ Z80 port speedups CODE TUCK ( a b -- b a b ) HL pop, BC push, HL push, ;CODE CODE NIP ( a b -- b ) HL pop, ;CODE CODE +! ( n a -- ) BC>HL, ldBC(HL), HL dec, (SP) HL ex, HL BC add, HL>BC, HL pop, (HL) C ld, HL inc, (HL) B ld, BC pop, ;CODE CODE A> BC push, IY push, BC pop, ;CODE CODE >A BC push, IY pop, BC pop, ;CODE CODE A>R IY push, HL pop, IX inc, IX inc, 0 ix+) L ld, 1 ix+) H ld, ;CODE CODE R>A L 0 ix+) ld, H 1 ix+) ld, IX dec, IX dec, HL push, IY pop, ;CODE CODE A+ IY inc, ;CODE CODE A- IY dec, ;CODE CODE AC@ BC push, C 0 iy+) ld, B 0 i) ld, ;CODE CODE AC! 0 iy+) C ld, BC pop, ;CODE \ Z80 port speedups CODE MOVE ( src dst u -- ) HL pop, DE HL ex, (SP) HL ex, BCZ, IFNZ, ldir, THEN, DE pop, BC pop, ;CODE CODE = HL pop, BC subHL, BC 0 i) ld, IFZ, BC inc, THEN, ;CODE CODE < HL pop, BC subHL, BC 0 i) ld, IFC, BC inc, THEN, ;CODE CODE CRC16 ( c n -- c ) BC push, exx, ( protect DE ) HL pop, ( n ) DE pop, ( c ) A L ld, A D xor, D A ld, B 8 i) ld, BEGIN, E sla, D rl, IFC, ( msb is set, apply polynomial ) A D ld, A $10 i) xor, D A ld, A E ld, A $21 i) xor, E A ld, THEN, BR djnz, DE push, exx, ( unprotect DE ) BC pop, ;CODE \ Z80 Assembler. Operands. See doc/asm. Requires B5 : >>3 >> >> >> ; : <<3 << << << ; : <<4 <<3 << ; : opreg 7 AND ; : optype >>3 3 AND ; CREATE nbank $10 ALLOT 0 VALUE nbank> : nbank@ ( op -- n ) opreg << nbank + @ ; : nbank! ( n -- idx ) nbank> TUCK << nbank + ! DUP 1+ opreg TO nbank> ; 28 CONSTS $00 B $01 C $02 D $03 E $04 H $05 L $06 (HL) $07 A $08 BC $09 DE $0a HL $0b AF $0b SP $20 (BC) $21 (DE) $22 (SP) $23 AF' $24 I $25 R $26 (C) $00 CNZ $01 CZ $02 CNC $03 CC $04 CPO $05 CPE $06 CP $07 CM : i) nbank! $10 OR ; : m) nbank! $18 OR ; : ix, $dd C, ; : iy, $fd C, ; : IX ix, HL ; : IY iy, HL ; : _ <<8 (HL) OR $40 OR ; : ix+) ix, _ ; : iy+) iy, _ ; \ Z80 Assembler. Checks, asserts, util : err ABORT" argument error" ; : # ( f -- ) NOT IF err THEN ; : HL# HL = # ; : A# A = # ; : 8b? optype 0 = ; : 16b? optype 1 = ; : ixy+? $40 AND ; : special? $20 AND ; : 8b# 8b? # ; : opexec ( op tbl -- ) SWAP optype WEXEC ; : opcode, ( opcode -- ) DUP >>8 ?DUP IF C, THEN C, ; : ?ixy+, ( op -- ) DUP ixy+? IF >>8 C, ELSE DROP THEN ; \ Z80 Assembler. sub, and, or, xor, cp, : _reg8, OVER opreg OR opcode, ?ixy+, ; : _imm, $46 OR opcode, nbank@ C, ; 4 WORDTBL _ ( op code -- ) 'W _reg8, 'W err 'W _imm, 'W err : 8bari, ( A op code -- ) ROT A# OVER _ opexec ; : op DOER , DOES> ( A op 'code -- ) @ 8bari, ; $a0 op and, $b8 op cp, $b0 op or, $90 op sub, $a8 op xor, \ Z80 Assembler. rl, rr, rlc, rrc, sla, srl, bit, set, res, 4 WORDTBL _ ( op code -- ) 'W _reg8, 'W err 'W err 'W err : op DOER , DOES> ( op 'code ) @ OVER _ opexec ; $cb10 op rl, $cb18 op rr, $cb00 op rlc, $cb08 op rrc, $cb20 op sla, $cb38 op srl, : op DOER , DOES> ( op b 'code ) @ SWAP <<3 OR OVER _ opexec ; $cbc0 op set, $cb80 op res, $cb40 op bit, \ Z80 Assembler. inc, dec, add, adc, sbc, : _reg8<<, @ OVER opreg <<3 OR C, ?ixy+, ; : _reg16<<, 2 + @ SWAP opreg <<4 OR opcode, ; : _ixy+<<, C, (HL) SWAP _reg8<<, nbank@ C, ; 4 WORDTBL _ ( op 'codes -- ) 'W _reg8<<, 'W _reg16<<, 'W err 'W err : op DOER ( 8b ) , ( 16b ) , DOES> ( op 'codes ) OVER _ opexec ;$03 04 op inc, $0b 05 op dec, : op DOER ( 8b ) , ( 16b ) , DOES> ( dst src 'codes -- ) OVER 16b? IF ROT HL# _reg16<<, ELSE @ 8bari, THEN ; $09 $80 op add, $ed4a $88 op adc, $ed42 $98 op sbc, \ Z80 Assembler. push, pop, in, out, rst, 4 WORDTBL _ ( op 'codes -- ) 'W err 'W _reg16<<, 'W err 'W err : op DOER 0 , , DOES> ( op 'code -- ) OVER _ opexec ; $c5 op push, $c1 op pop, : _A, ( n in? ) <<3 $d3 OR C, nbank@ C, ; : _C, ( reg in? ) NOT $ed40 OR SWAP <<3 OR opcode, ; : _inout, ( op n-or-C in? ) OVER (C) = IF NIP _C, ELSE ROT DROP _A, THEN ; : in, 1 _inout, ; : out, SWAP 0 _inout, ; : rst, ( n ) $c7 OR C, ; CREATE _ 9 nC, AF DE (SP) AF' HL HL $08 $eb $e3 : ex, ( op1 op2 -- ) SWAP _ 3 [C]? DUP 0>= # 3 + _ + DUP C@ ROT = # 3 + C@ C, ; \ Z80 Assembler. Inherent ops : op DOER , DOES> @ opcode, ; $f3 op di, $fb op ei, $d9 op exx, $76 op halt, $00 op nop, $37 op scf, $3f op ccf, $c9 op ret, $17 op rla, $07 op rlca, $1f op rra, $0f op rrca, $eda1 op cpi, $edb1 op cpir, $eda9 op cpd, $edb9 op cpdr, $ed46 op im0, $ed56 op im1, $ed5e op im2, $eda0 op ldi, $edb0 op ldir, $eda8 op ldd, $edb8 op lddr, $ed44 op neg, $ed4d op reti, $ed45 op retn, $eda2 op ini, $edaa op ind, $eda3 op outi, \ Z80 Assembler. ld, CREATE _s1 $0a , $1a , 0 , 0 , $ed57 , $ed5f , 0 , 0 , CREATE _s2 $02 , $12 , 0 , 0 , $ed47 , $ed4f , 0 , 0 , : _r8 OVER opreg <<3 OVER opreg OR $40 OR C, OR ?ixy+, ; : _sp DUP special? IF NIP _s1 ELSE DROP _s2 THEN SWAP opreg << + @ opcode, ; : _n ( dst src -- i mask 16b? ) nbank@ SWAP DUP 16b? IF opreg <<4 1 ELSE opreg <<3 0 THEN ; 4 WORDTBL _ ( dst src -- ) \ sel on src. dst should be a reg :W 2DUP OR special? IF _sp ELSE _r8 THEN ; :W HL# SP = # $f9 C, ; :W _n IF $01 OR C, L, ELSE $06 OR C, C, THEN ; :W 2DUP < <<3 ROT> <> _n IF DUP $20 = IF $02 ELSE $ed43 THEN OR ROT OR ELSE $38 = # SWAP $32 OR THEN opcode, L, ; : ld, ( dst src -- ) OVER optype OVER optype MAX _ SWAP WEXEC ; \ Z80 Assembler. Macros : clrA, A A xor, ; : subHL, A A or, HL SWAP sbc, ; : pushA, B 0 i) ld, C A ld, BC push, ; : HLZ, A H ld, A L or, ; : DEZ, A D ld, A E or, ; : BCZ, A B ld, A C or, ; : ldDE(HL), E (HL) ld, HL inc, D (HL) ld, ; : ldBC(HL), C (HL) ld, HL inc, B (HL) ld, ; : ldHL(HL), A (HL) ld, HL inc, H (HL) ld, L A ld, ; : outHL, A H ld, DUP A out, A L ld, A out, ; : outDE, A D ld, DUP A out, A E ld, A out, ; : HL>BC, B H ld, C L ld, ; : BC>HL, H B ld, L C ld, ; : A>BC, C A ld, B 0 i) ld, ; : A>HL, L A ld, H 0 i) ld, ; \ Z80 Assembler. Jumps, calls and HAL : cond ( cond opcode -- opcode ) SWAP <<3 OR ; : br8, ( n opcode -- ) C, C, ; : jr, $18 br8, ; : djnz, $10 br8, ; : jrc, $20 cond br8, ; : br16, ( n opcode -- ) C, L, ; : jp, $c3 br16, ; : call, $cd br16, ; : jpc, $c2 cond br16, ; : callc, $c4 cond br16, ; : retc, $c0 cond C, ; : jp(HL), $e9 C, ; : jp(IX), IX DROP jp(HL), ; : jp(IY), IY DROP jp(HL), ; ALIAS jp, JMPi, ALIAS jr, JRi, : JMP(i), m) HL SWAP ld, jp(HL), ; : CALLi, DUP $38 AND OVER = IF rst, ELSE call, THEN ; : JRZi, CZ jrc, ; : JRNZi, CNZ jrc, ; : JRCi, CC jrc, ; : JRNCi, CNC jrc, ; : i>, BC push, i) BC SWAP ld, ; : (i)>, BC push, m) BC SWAP ld, ; CODE AT28C! ( c a -- ) BC>HL, BC pop, (HL) C ld, A C ld, ( orig ) B C ld, ( save ) C (HL) ld, ( poll ) BEGIN, A (HL) ld, ( poll ) A C cp, ( same as old? ) C A ld, ( save old poll, Z preserved ) BR CNZ jrc, \ equal to written? SUB instead of CP to ensure IOERR is NZ A B sub, IFNZ, SYSVARS ( IOERR ) m) A ld, THEN, BC pop, ;CODE : AT28! ( n a -- ) 2DUP AT28C! 1+ SWAP >>8 SWAP AT28C! ; ( SPI relay driver. See doc/hw/z80/spi.txt ) CODE (spix) ( n -- n ) A C ld, SPI_DATA i) A out, \ wait until xchg is done BEGIN, A SPI_CTL i) in, A 1 i) and, BR CNZ jrc, A SPI_DATA i) in, C A ld, ;CODE CODE (spie) ( n -- ) A C ld, SPI_CTL i) A out, BC pop, ;CODE ( Z80 driver for TMS9918. Implements grid protocol. Requires TMS_CTLPORT, TMS_DATAPORT and ~FNT from the Font compiler at B520. Patterns are at addr $0000, Names are at $3800. Load range B315-317 ) CODE _ctl ( a -- sends LSB then MSB ) A C ld, TMS_CTLPORT i) A out, A B ld, TMS_CTLPORT i) A out, BC pop, ;CODE CODE _data A C ld, TMS_DATAPORT i) A out, BC pop, ;CODE : _zero ( x -- send 0 _data x times ) ( x ) >R BEGIN 0 _data NEXT ; ( Each row in ~FNT is a row of the glyph and there is 7 of them. We insert a blank one at the end of those 7. ) : _sfont ( a -- a+7, Send font to TMS ) 7 >R BEGIN C@+ _data NEXT ( blank row ) 0 _data ; : _sfont^ ( a -- a+7, Send inverted font to TMS ) 7 >R BEGIN C@+ $ff XOR _data NEXT ( blank row ) $ff _data ; : CELL! ( c pos ) $7800 OR _ctl ( tilenum ) SPC - ( glyph ) $5f MOD _data ; : CURSOR! ( new old -- ) DUP $3800 OR _ctl [ TMS_DATAPORT LITN ] PC@ $7f AND ( new old glyph ) SWAP $7800 OR _ctl _data DUP $3800 OR _ctl [ TMS_DATAPORT LITN ] PC@ $80 OR ( new glyph ) SWAP $7800 OR _ctl _data ; : COLS 40 ; : LINES 24 ; : TMS$ $8100 _ctl ( blank screen ) $7800 _ctl COLS LINES * _zero $4000 _ctl $5f >R ~FNT BEGIN _sfont NEXT DROP $4400 _ctl $5f >R ~FNT BEGIN _sfont^ NEXT DROP $820e _ctl ( name table $3800 ) $8400 _ctl ( pattern table $0000 ) $87f0 _ctl ( colors 0 and 1 ) $8000 _ctl $81d0 _ctl ( text mode, display on ) ; ( MC6850 Driver. Load range B320-B322. Requires: 6850_CTL for control register 6850_IO for data register. CTL numbers used: $16 = no interrupt, 8bit words, 1 stop bit 64x divide. $56 = RTS high ) CODE 6850> BEGIN, A 6850_CTL i) in, A $02 i) and, ( are we transmitting? ) BR CZ jrc, ( yes, loop ) A C ld, 6850_IO i) A out, BC pop, ;CODE CODE 6850<? BC push, clrA, ( 256x ) A $16 i) ( RTS lo ) ld, 6850_CTL i) A out, BC 0 i) ld, ( pre-push a failure ) BEGIN, AF AF' ex, ( preserve cnt ) A 6850_CTL i) in, A $1 i) and, ( rcv buff full? ) IFNZ, ( full ) A 6850_IO i) in, pushA, C 1 i) ld, clrA, ( end loop ) ELSE, AF AF' ex, ( recall cnt ) A dec, THEN, BR CNZ jrc, A $56 i) ( RTS hi ) ld, 6850_CTL i) A out, ;CODE ALIAS 6850<? RX<? ALIAS 6850<? (key?) ALIAS 6850> TX> ALIAS 6850> (emit) : 6850$ $56 ( RTS high ) [ 6850_CTL LITN ] PC! ; ( Zilog SIO driver. Load range B325-328. Requires: SIOA_CTL for ch A control register SIOA_DATA for data SIOB_CTL for ch B control register SIOB_DATA for data ) CODE SIOA<? BC push, clrA, ( 256x ) BC 0 i) ld, ( pre-push a failure ) A 5 i) ( PTR5 ) ld, SIOA_CTL i) A out, A $68 i) ( RTS low ) ld, SIOA_CTL i) A out, BEGIN, AF AF' ex, ( preserve cnt ) A SIOA_CTL i) in, A $1 i) and, ( rcv buff full? ) IFNZ, ( full ) A SIOA_DATA i) in, pushA, C 1 i) ld, clrA, ( end loop ) ELSE, AF AF' ex, ( recall cnt ) A dec, THEN, BR CNZ jrc, A 5 i) ( PTR5 ) ld, SIOA_CTL i) A out, A $6a i) ( RTS high ) ld, SIOA_CTL i) A out, ;CODE CODE SIOA> BEGIN, A SIOA_CTL i) in, A $04 i) and, ( are we transmitting? ) BR CZ jrc, ( yes, loop ) A C ld, SIOA_DATA i) A out, BC pop, ;CODE CREATE _ ( init data ) $18 C, ( CMD3 ) $24 C, ( CMD2/PTR4 ) $c4 C, ( WR4/64x/1stop/nopar ) $03 C, ( PTR3 ) $c1 C, ( WR3/RXen/8char ) $05 C, ( PTR5 ) $6a C, ( WR5/TXen/8char/RTS ) $21 C, ( CMD2/PTR1 ) 0 C, ( WR1/Rx no INT ) : SIOA$ _ >A 9 >R BEGIN AC@+ [ SIOA_CTL LITN ] PC! NEXT ; CODE SIOB<? BC push, ( copy/paste of SIOA<? ) clrA, ( 256x ) BC 0 i) ld, ( pre-push a failure ) A 5 i) ( PTR5 ) ld, SIOB_CTL i) A out, A $68 i) ( RTS low ) ld, SIOB_CTL i) A out, BEGIN, AF AF' ex, ( preserve cnt ) A SIOB_CTL i) in, A $1 i) and, ( rcv buff full? ) IFNZ, ( full ) A SIOB_DATA i) in, pushA, C 1 i) ld, clrA, ( end loop ) ELSE, AF AF' ex, ( recall cnt ) A dec, THEN, BR CNZ jrc, A 5 i) ( PTR5 ) ld, SIOB_CTL i) A out, A $6a i) ( RTS high ) ld, SIOB_CTL i) A out, ;CODE CODE SIOB> BEGIN, A SIOB_CTL i) in, A $04 i) and, ( are we transmitting? ) BR CZ jrc, ( yes, loop ) A C ld, SIOB_DATA i) A out, BC pop, ;CODE : SIOB$ _ >A 9 >R BEGIN AC@+ [ SIOB_CTL LITN ] PC! NEXT ; \ VDP Driver. see doc/hw/sms/vdp. Load range B330-B332. CREATE _idat $04 C, $80 C, \ Bit 2: Select mode 4 $00 C, $81 C, $0f C, $82 C, \ Name table: $3800, *B0 must be 1* $ff C, $85 C, \ Sprite table: $3f00 $ff C, $86 C, \ sprite use tiles from $2000 $ff C, $87 C, \ Border uses palette $f $00 C, $88 C, \ BG X scroll $00 C, $89 C, \ BG Y scroll $ff C, $8a C, \ Line counter (why have this?) \ VDP driver : _sfont ( a -- a+7, Send font to VDP ) 7 >R BEGIN C@+ _data 3 _zero NEXT ( blank row ) 4 _zero ; : CELL! ( c pos ) 2 * $7800 OR _ctl ( c ) $20 - ( glyph ) $5f MOD _data ; \ VDP driver : CURSOR! ( new old -- ) ( unset palette bit in old tile ) 2 * 1+ $7800 OR _ctl 0 _data ( set palette bit for at specified pos ) 2 * 1+ $7800 OR _ctl $8 _data ; : VDP$ 9 >R _idat BEGIN DUP @ _ctl 1+ 1+ NEXT DROP ( blank screen ) $7800 _ctl COLS LINES * 2 * _zero ( palettes ) $c000 _ctl ( BG ) 1 _zero $3f _data 14 _zero ( sprite, inverted colors ) $3f _data 15 _zero $4000 _ctl $5f >R ~FNT BEGIN _sfont NEXT DROP ( bit 6, enable display, bit 7, ?? ) $81c0 _ctl ; : COLS 32 ; : LINES 24 ; \ SMS pad driver. See doc/hw/z80/sms/pad. Load range: 355-358 : _prevstat [ PAD_MEM LITN ] ; : _sel [ PAD_MEM 1+ LITN ] ; : _next [ PAD_MEM 2 + LITN ] ; : _sel+! ( n -- ) _sel C@ + _sel C! ; : _status ( -- n, see doc ) 1 _THA! ( output, high/unselected ) _D1@ $3f AND ( low 6 bits are good ) ( Start and A are returned when TH is selected, in bits 5 and 4. Well get them, left-shift them and integrate them to B. ) 0 _THA! ( output, low/selected ) _D1@ $30 AND << << OR ; : _chk ( c --, check _sel range ) _sel C@ DUP $7f > IF $20 _sel C! THEN $20 < IF $7f _sel C! THEN ; CREATE _ '0' C, ':' C, 'A' C, '[' C, 'a' C, $ff C, : _nxtcls _sel @ >R _ BEGIN ( a R:c ) C@+ R@ > UNTIL ( a R:c ) R~ 1- C@ _sel ! ; : _updsel ( -- f, has an action button been pressed? ) _status _prevstat C@ OVER = IF DROP 0 EXIT THEN DUP _prevstat C! ( changed, update ) ( s ) $01 ( UP ) OVER AND NOT IF 1 _sel+! THEN $02 ( DOWN ) OVER AND NOT IF -1 _sel+! THEN $04 ( LEFT ) OVER AND NOT IF -5 _sel+! THEN $08 ( RIGHT ) OVER AND NOT IF 5 _sel+! THEN $10 ( BUTB ) OVER AND NOT IF _nxtcls THEN ( update sel in VDP ) _chk _sel C@ XYPOS CELL! ( return whether any of the high 3 bits is low ) $e0 AND $e0 < ; : (key?) ( -- c? f ) _next C@ IF _next C@ 0 _next C! 1 EXIT THEN _updsel IF _prevstat C@ $20 ( BUTC ) OVER AND NOT IF DROP _sel C@ 1 EXIT THEN $40 ( BUTA ) AND NOT IF $8 ( BS ) 1 EXIT THEN ( If not BUTC or BUTA, it has to be START ) $d _next C! _sel C@ 1 ELSE 0 ( f ) THEN ; : PAD$ $ff _prevstat C! 'a' _sel C! 0 _next C! ; ( kbd - implement (ps2kc) for SMS PS/2 adapter ) : (ps2kcA) ( for port A ) ( Before reading a character, we must first verify that there is something to read. When the adapter is finished filling its '164 up, it resets the latch, which output's is connected to TL. When the '164 is full, TL is low. Port A TL is bit 4 ) _D1@ $10 AND IF 0 EXIT ( nothing ) THEN 0 _THA! ( Port A TH output, low ) _D1@ ( bit 3:0 go in 3:0 ) $0f AND ( n ) 1 _THA! ( Port A TH output, high ) _D1@ ( bit 3:0 go in 7:4 ) $0f AND << << << << OR ( n ) 2 _THA! ( TH input ) ; : (ps2kcB) ( for port B ) ( Port B TL is bit 2 ) _D2@ $04 AND IF 0 EXIT ( nothing ) THEN 0 _THB! ( Port B TH output, low ) _D1@ ( bit 7:6 go in 1:0 ) >> >> >> >> >> >> ( n ) _D2@ ( bit 1:0 go in 3:2 ) $03 AND << << OR ( n ) 1 _THB! ( Port B TH output, high ) _D1@ ( bit 7:6 go in 5:4 ) $c0 AND >> >> OR ( n ) _D2@ ( bit 1:0 go in 7:6 ) $03 AND <<8 >> >> OR ( n ) 2 _THB! ( TH input ) ; : (spie) DROP ; ( always enabled ) CODE (spix) ( x -- x, for port B ) \ TR = DATA TH = CLK A CPORT_MEM m) ld, A $f3 i) and, ( TR/TH output ) B 8 i) ld, BEGIN, A $bf i) and, ( TR lo ) C rl, IFC, A $40 i) or, ( TR hi ) THEN, CPORT_CTL i) A out, ( clic! ) A $80 i) or, ( TH hi ) CPORT_CTL i) A out, ( clac! ) AF AF' ex, A CPORT_D1 i) in, ( Up Btn is B6 ) rla, rla, L rl, AF AF' ex, A $7f i) and, ( TH lo ) CPORT_CTL i) A out, ( cloc! ) BR djnz, CPORT_MEM m) A ld, C L ld, ;CODE \ Routines for interacting with SMS controller ports. \ Requires CPORT_MEM, CPORT_CTL, CPORT_D1 and CPORT_D2 to be \ defined. CPORT_MEM is a 1 byte buffer for CPORT_CTL. The last \ 3 consts will usually be $3f, $dc, $dd. \ mode -- set TR pin on mode a on: \ 0= output low 1=output high 2=input CODE _TRA! ( B0 -> B4, B1 -> B0 ) C rr, rla, rla, rla, rla, B rr, rla, A $11 i) and, C A ld, A CPORT_MEM m) ld, A $ee i) and, A C or, CPORT_CTL i) A out, CPORT_MEM m) A ld, BC pop, ;CODE CODE _THA! ( B0 -> B5, B1 -> B1 ) C rr, rla, rla, rla, rla, C rr, rla, rla, A $22 i) and, C A ld, A CPORT_MEM m) ld, A $dd i) and, A C or, CPORT_CTL i) A out, CPORT_MEM m) A ld, BC pop, ;CODE CODE _TRB! ( B0 -> B6, B1 -> B2 ) C rr, rla, rla, rla, rla, C rr, rla, rla, rla, A $44 i) and, C A ld, A CPORT_MEM m) ld, A $bb i) and, A C or, CPORT_CTL i) A out, CPORT_MEM m) A ld, BC pop, ;CODE CODE _THB! ( B0 -> B7, B1 -> B3 ) C rr, rla, rla, rla, rla, C rr, rla, rla, rla, rla, A $88 i) and, C A ld, A CPORT_MEM m) ld, A $77 i) and, A C or, CPORT_CTL i) A out, CPORT_MEM m) A ld, BC pop, ;CODE CODE _D1@ BC push, A CPORT_D1 i) in, C A ld, B 0 i) ld, ;CODE CODE _D2@ BC push, A CPORT_D2 i) in, C A ld, B 0 i) ld, ;CODE ( TI-84+ LCD driver. See doc/hw/z80/ti84/lcd.txt Load range: 350-353 ) : _mem+ [ LCD_MEM LITN ] @ + ; : FNTW 3 ; : FNTH 5 ; : COLS 96 FNTW 1+ / ; : LINES 64 FNTH 1+ / ; ( Wait until the lcd is ready to receive a command. It's a bit weird to implement a waiting routine in asm, but the forth version is a bit heavy and we don't want to wait longer than we have to. ) CODE _wait BEGIN, A $10 i) ( CMD ) in, rla, ( When 7th bit is clr, we can send a new cmd ) BR CC jrc, ;CODE : LCD_BUF 0 _mem+ ; : _cmd $10 ( CMD ) PC! _wait ; : _data! $11 ( DATA ) PC! _wait ; : _data@ $11 ( DATA ) PC@ _wait ; : LCDOFF $02 ( CMD_DISABLE ) _cmd ; : LCDON $03 ( CMD_ENABLE ) _cmd ; : _yinc $07 _cmd ; : _xinc $05 _cmd ; : _zoff! ( off -- ) $40 + _cmd ; : _col! ( col -- ) $20 + _cmd ; : _row! ( row -- ) $80 + _cmd ; : LCD$ HERE [ LCD_MEM LITN ] ! FNTH 2 * ALLOT LCDON $01 ( 8-bit mode ) _cmd FNTH 1+ _zoff! ; : _clrrows ( n u -- Clears u rows starting at n ) >R _row! BEGIN _yinc 0 _col! 11 >R BEGIN 0 _data! NEXT _xinc 0 _data! NEXT ; : NEWLN ( oldln -- newln ) 1+ DUP 1+ FNTH 1+ * _zoff! ( ln ) DUP FNTH 1+ * FNTH 1+ _clrrows ( newln ) ; : LCDCLR 0 64 _clrrows ; : _atrow! ( pos -- ) COLS / FNTH 1+ * _row! ; : _tocol ( pos -- col off ) COLS MOD FNTW 1+ * 8 /MOD ; : CELL! ( c pos -- ) DUP _atrow! DUP _tocol _col! ROT ( pos coff c ) $20 - FNTH * ~FNT + ( pos coff a ) _xinc _data@ DROP A> >R LCD_BUF >A FNTH >R BEGIN ( pos coff a ) OVER 8 -^ SWAP C@+ ( pos coff 8-coff a+1 c ) ROT LSHIFT _data@ <<8 OR ( pos coff a+1 c ) DUP A> FNTH + C! >>8 AC!+ NEXT 2DROP ( pos ) DUP _atrow! LCD_BUF >A FNTH >R BEGIN AC@+ _data! NEXT DUP _atrow! _tocol NIP 1+ _col! FNTH >R BEGIN AC@+ _data! NEXT R> >A ; \ Requires KBD_MEM, KBD_PORT and nC, from B120. \ Load range: 355-359 \ gm -- pm, get pressed keys mask for group mask gm CODE _get di, A $ff i) ld, KBD_PORT i) A out, A C ld, KBD_PORT i) A out, A KBD_PORT i) in, ei, C A ld, ;CODE \ wait until all keys are de-pressed. To avoid repeat keys, we \ require 64 subsequent polls to indicate all depressed keys. \ all keys are considered depressed when the 0 group returns \ $ff. : _wait 64 BEGIN 0 _get $ff = NOT IF DROP 64 THEN 1- DUP NOT UNTIL DROP ; \ digits table. each row represents a group. 0 means unsupported\ no group 7 because it has no key. $80 = alpha, $81 = 2nd CREATE _dtbl 7 8 * nC, 0 0 0 0 0 0 0 0 $d '+' '-' '*' '/' '^' 0 0 0 '3' '6' '9' ')' 0 0 0 '.' '2' '5' '8' '(' 0 0 0 '0' '1' '4' '7' ',' 0 0 0 0 0 0 0 0 0 0 $80 0 0 0 0 0 $81 0 $7f \ alpha table. same as _dtbl, for when we're in alpha mode. CREATE _atbl 7 8 * nC, 0 0 0 0 0 0 0 0 $d '"' 'W' 'R' 'M' 'H' 0 0 '?' 0 'V' 'Q' 'L' 'G' 0 0 ':' 'Z' 'U' 'P' 'K' 'F' 'C' 0 32 'Y' 'T' 'O' 'J' 'E' 'B' 0 0 'X' 'S' 'N' 'I' 'D' 'A' $80 0 0 0 0 0 $81 0 $7f : _@ [ KBD_MEM LITN ] C@ ; : _! [ KBD_MEM LITN ] C! ; : _2nd@ _@ 1 AND ; : _2nd! _@ $fe AND + _! ; : _alpha@ _@ 2 AND ; : _alpha! 2 * _@ $fd AND + _! ; : _alock@ _@ 4 AND ; : _alock^ _@ 4 XOR _! ; : _gti ( -- tindex, that it, index in _dtbl or _atbl ) 7 >R 0 BEGIN ( gid ) 1 OVER LSHIFT $ff -^ ( gid dmask ) _get DUP $ff = IF DROP 1+ ELSE R~ 1 >R THEN NEXT ( gid dmask ) _wait $ff XOR ( dpos ) 0 ( dindex ) BEGIN 1+ 2DUP RSHIFT NOT UNTIL 1- ( gid dpos dindex ) NIP ( gid dindex ) SWAP 8 * + ; : (key?) ( -- c? f ) 0 _get $ff = IF ( no key pressed ) 0 EXIT THEN _alpha@ _alock@ IF NOT THEN IF _atbl ELSE _dtbl THEN _gti + C@ ( c ) DUP $80 = IF _2nd@ IF _alock^ ELSE 1 _alpha! THEN THEN DUP $81 = _2nd! DUP 1 $7f =><= IF ( we have something ) ( lower? ) _2nd@ IF DUP 'A' 'Z' =><= IF $20 OR THEN THEN 0 _2nd! 0 _alpha! 1 ( c f ) ELSE ( nothing ) DROP 0 THEN ; : KBD$ 0 [ KBD_MEM LITN ] C! ; \ TRS-80 drivers declarations and macros \ FDMEM 3b: FDSEL 1b FDOP 2b : TRS804P 381 389 LOADR ; $f800 VALUE VIDMEM $bf VALUE CURCHAR 0 VALUE lblflush : fdstat A $f0 i) in, ; : fdcmd ( i ) A SWAP i) ld, B $18 i) ld, $f0 i) A out, BEGIN, BR djnz, ; : fdwait BEGIN, fdstat rrca, BR CC jrc, rlca, ; : vid+, ( reg -- ) HL VIDMEM i) ld, HL SWAP add, ; \ TRS-80 4P video driver 24 CONSTANT LINES 80 CONSTANT COLS CODE CELL! ( c pos -- ) HL pop, A L ld, BC vid+, (HL) A ld, BC pop, ;CODE CODE CELLS! ( a pos u -- ) BC push, exx, BC pop, DE pop, DE vid+, DE HL ex, HL pop, BCZ, IFNZ, ldir, THEN, exx, BC pop,;CODE CODE CURSOR! ( new old -- ) BC vid+, A (HL) ld, A CURCHAR i) cp, IFZ, A UNDERCUR m) ld, (HL) A ld, THEN, BC pop, BC vid+, A (HL) ld, UNDERCUR m) A ld, A CURCHAR i) ld, (HL) A ld, BC pop, ;CODE CODE SCROLL ( -- ) exx, HL VIDMEM 80 + i) ld, DE VIDMEM i) ld, BC 1840 i) ld, ldir, H D ld, L E ld, DE inc, A SPC i) ld, (HL) A ld, BC 79 i) ld, ldir, exx, ;CODE : NEWLN ( old -- new ) 1+ DUP LINES = IF 1- SCROLL THEN ; LSET L2 ( seek, B=trk ) A 21 i) ld, A B cp, A FDMEM m) ld, IFC, A $20 i) or, ( WP ) THEN, A $80 i) or, $f4 i) A out, \ FD sel A B ld, ( trk ) $f3 i) A out, $1c fdcmd ret, CODE FDRD ( trksec addr -- st ) BC>HL, BC pop, L2 call, fdwait A $98 i) and, IFZ, di, A C ld, $f2 i) A out, ( sec ) C $f3 i) ld, $84 fdcmd \ read BEGIN, BEGIN, fdstat A $b6 i) and, BR CZ jrc, \ DRQ A $b4 i) and, IFZ, TO L3 ( error ) ini, BR CNZ jrc, THEN, fdwait A $3c i) and, L3 FMARK A>BC, ei, ;CODE CODE FDWR ( trksec addr -- st ) BC>HL, BC pop, L2 call, fdwait A $98 i) and, IFZ, di, A C ld, $f2 i) A out, ( sec ) C $f3 i) ld, $a4 fdcmd \ read BEGIN, BEGIN, fdstat A $f6 i) and, BR CZ jrc, \ DRQ A $f4 i) and, IFZ, TO L3 ( error ) outi, BR CNZ jrc, THEN, fdwait A $3c i) and, L3 FMARK A>BC, ei, ;CODE CODE _dsel ( fdmask -- ) A C ld, FDMEM m) A ld, A $80 i) or, $f4 i) A out, 0 fdcmd ( restore ) fdwait BC pop, ;CODE : DRVSEL ( drv -- ) 1 SWAP LSHIFT [ FDMEM LITN ] C@ OVER = NOT IF _dsel ELSE DROP THEN ; : FD$ 1 DRVSEL ; FDMEM 1+ DUP CONSTANT 'FDOP *ALIAS FDOP : _err S" FDerr " STYPE .X ABORT ; : _trksec ( sec -- trksec ) \ 4 256b sectors per block, 18 sec per trk, 40 trk max 18 /MOD ( sec trk ) DUP 39 > IF $ffff _err THEN <<8 + ; : FD@! ( blk blk( -- ) A> >R SWAP << << ( blk*4=sec ) >A 4 >R BEGIN ( dest ) A> A+ _trksec OVER ( dest trksec dest ) FDOP ( dest ) ?DUP IF _err THEN $100 + NEXT DROP R> >A ; : FD@ ['] FDRD 'FDOP ! FD@! ; : FD! ['] FDWR 'FDOP ! FD@! ; : CL$ ( baudcode -- ) $02 $e8 PC! ( UART RST ) DUP 16 * OR $e9 PC! ( bauds ) $6d $ea PC! ( word8 no parity no-RTS ) ; CODE TX> BEGIN, A $ea i) in, A $40 i) and, IFNZ, ( TX reg empty ) A $e8 i) in, A $80 i) and, IFZ, ( CTS low ) A C ld, $eb i) A out, ( send byte ) BC pop, ;CODE THEN, THEN, BR jr, CODE RX<? BC push, clrA, ( 256x ) BC 0 i) ld, ( pre-push a failure ) A $6c i) ( RTS low ) ld, $ea i) A out, BEGIN, AF AF' ex, ( preserve cnt ) A $ea i) in, A $80 i) and, ( rcv buff full? ) IFNZ, ( full ) A $eb i) in, A>HL, HL push, C inc, clrA, ( end loop ) ELSE, AF AF' ex, ( recall cnt ) A dec, THEN, BR CNZ jrc, A $6d i) ( RTS high ) ld, $ea i) A out, ;CODE LSET L1 6 nC, '`' 'h' 'p' 'x' '0' '8' LSET L2 8 nC, $0d 0 $ff 0 0 $08 0 $20 PC XORG $39 + T! ( RST 38 ) AF push, HL push, DE push, BC push, A $ec i) in, ( RTC INT ack ) A $f440 m) ld, A A or, IFNZ, \ 7th row is special HL L2 1- i) ld, BEGIN, HL inc, rra, BR CNC jrc, A (HL) ld, ELSE, \ not 7th row HL L1 i) ld, DE $f401 i) ld, BC $600 i) ld, BEGIN, A (DE) ld, A A or, IFNZ, C (HL) ld, BEGIN, C inc, rra, BR CNC jrc, C dec, THEN, E sla, HL inc, BR djnz, A C ld, THEN, \ cont. \ A=char or zero if no keypress. Now let's debounce HL KBD_MEM 2 + i) ld, A A or, IFZ, \ no keypress, debounce (HL) A ld, ELSE, \ keypress, is it debounced? A (HL) cp, IFNZ, \ != debounce buffer C A ld, (HL) C ld, A $ff i) cp, IFZ, \ BREAK! HL pop, HL pop, HL pop, HL pop, HL pop, ei, X' QUIT jp, THEN, HL dec, A $f480 m) ld, A 3 i) and, (HL) A ld, HL dec, (HL) C ld, THEN, THEN, BC pop, DE pop, HL pop, AF pop, ei, ret, KBD_MEM CONSTANT KBDBUF \ LSB=char MSB=shift : KBD$ 0 KBDBUF ! $04 $e0 PC! ( enable RTC INT ) (im1) ; : (key?) KBDBUF @ DUP <<8 >>8 NOT IF DROP 0 EXIT THEN 0 KBDBUF ! L|M ( char flags ) OVER '<' '`' =><= IF 1 XOR THEN \ invert shift TUCK 1 AND IF \ lshift ( flags char ) DUP '@' < IF $ef ELSE $df THEN AND THEN SWAP 2 AND IF \ rshift ( char ) DUP '1' < IF $2f ELSE $4a THEN + THEN 1 ( success ) ; \ TRS-80 4P bootloader. Loads sectors 2-17 to addr 0. di, A $86 i) ld, $84 i) A out, \ mode 2, 80 chars, page 1 A $81 i) ld, $f4 i) A out, \ DRVSEL DD, drv0 A $40 i) ld, $ec i) A out, \ MODOUT 4MHZ, no EXTIO HL 0 i) ld, ( dest addr ) clrA, $e4 i) A out, ( no NMI ) A inc, ( trk1 ) BEGIN, $f3 i) A out, AF AF' ex, ( save ) $18 ( seek ) fdcmd fdwait clrA, $f2 i) A out, C $f3 i) ld, BEGIN, $80 ( read sector ) fdcmd ( B=0 ) BEGIN, fdstat rra, rra, BR CNC jrc, ( DRQ ) ini, A $c1 i) ld, BEGIN, $f4 i) A out, ini, BR CNZ jrc, fdwait A $1c i) ( error mask ) and, IFNZ, A SPC i) add, VIDMEM m) A ld, BEGIN, BR jr, THEN, A $f2 i) in, A inc, $f2 i) A out, A 18 i) cp, BR CC jrc, AF AF' ex, ( restore ) A inc, A 3 i) cp, BR CC jrc, 0 rst, \ Dan SBC drivers. See doc/hw/z80/dan.txt \ Macros : OUTii, ( val port -- ) A ROT i) ld, i) A out, ; : repeat ( n -- ) >R ' BEGIN ( w ) DUP EXECUTE NEXT DROP ; \ SPI relay driver CODE (spix) ( n -- n ) A C ld, SPI_DATA i) A out, ( wait until xchg is done ) nop, nop, nop, nop, A SPI_DATA i) in, C A ld, ;CODE CODE (spie) ( n -- ) $9A CTL8255 OUTii, $3 CTL8255 OUTii, A C ld, A 1 i) xor, A 1 i) and, CTL8255 i) A out, BC pop, ;CODE \ software framebuffer subsystem VID_MEM CONSTANT VD_DECFR VID_MEM $02 + CONSTANT VD_DECTL VID_MEM $04 + CONSTANT VD_CURCL VID_MEM $06 + CONSTANT VD_FRMST VID_MEM $08 + CONSTANT VD_COLS VID_MEM $0A + CONSTANT VD_LINES VID_MEM $0C + CONSTANT VD_FRB VID_MEM $0E + CONSTANT VD_OFS \ Clear Framebuffer CODE (vidclr) ( -- ) BC push, $9A CTL8255 OUTii, $3 CTL8255 OUTii, $1 CTL8255 OUTii, BC VID_MEM $10 + i) ld, HL VID_WDTH VID_SCN * i) ld, BEGIN, clrA, (BC) A ld, BC inc, HL dec, HLZ, BR CNZ jrc, BC pop, ;CODE : VID_OFS [ VID_WDTH 8 * LITN ] * + VD_FRB @ + VD_OFS ! (vidclr) ; : VID$ ( -- ) 1 VD_DECFR ! 0 VD_DECTL ! 0 VD_CURCL ! 0 VD_FRMST ! [ VID_WDTH 1 - LITN ] VD_COLS ! [ VID_LN 1 - LITN ] VD_LINES ! [ VID_MEM $10 + LITN ] VD_FRB ! 1 4 VID_OFS ; : COLS VD_COLS @ ; : LINES VD_LINES @ ; : VID_LOC VD_COLS @ /MOD [ VID_WDTH 8 * LITN ] * VD_OFS @ + ; : CELL! VID_LOC + SWAP SPC - DUP 96 < IF DUP DUP << + << + ~FNT + 7 >R BEGIN 2DUP C@ >> SWAP C! 1+ SWAP [ VID_WDTH LITN ] + SWAP NEXT DROP 0 SWAP C! ELSE 2DROP THEN ; : VID_LCR VID_LOC SWAP DUP DUP 12 < IF DROP 0 ELSE 12 - DUP [ VID_WDTH 24 - LITN ] > IF DROP [ VID_WDTH 24 - LITN ] THEN THEN VD_CURCL ! ; : CURSOR! 0 SWAP VID_LOC + [ VID_WDTH 7 * LITN ] + C! 255 SWAP VID_LCR + [ VID_WDTH 7 * LITN ] + C! ; CODE (vidscr) BC push, exx, BC VID_SCN 8 - VID_WDTH * i) ld, DE VID_MEM $10 + i) ld, HL VID_MEM $10 + VID_WDTH 8 * + i) ld, ldir, HL VID_WDTH 8 * i) ld, BEGIN, clrA, (DE) A ld, DE inc, HL dec, HLZ, BR CNZ jrc, exx, BC pop, ;CODE : NEWLN DUP 1+ VD_LINES @ = IF (vidscr) ELSE 1+ THEN ; \ Stream video frames, single scan CODE (vidfr) ( -- ) BC push, exx, C SPI_DATA i) ld, DE VID_MEM $04 + m) ld, HL VID_MEM 40 + VID_WDTH - i) ld, HL DE add, VID_MEM $06 + m) HL ld, DE VID_WDTH 24 - i) ld, B VID_SCN i) ld, LSET L1 BEGIN, 6 CTL8255 OUTii, HL DE add, 7 CTL8255 OUTii, A B ld, 4 repeat nop, 24 repeat outi, B A ld, BR djnz, B 0 i) ld, B 0 i) ld, B 0 i) ld, B VID_VBL 1 - i) ld, FJR jr, LSET L2 A VID_VBL 1 - i) ld, FJR jr, FMARK FMARK A B ld, B 28 i) ld, BEGIN, BR djnz, HL inc, B A ld, 7 CTL8255 OUTii, 5 repeat nop, 6 CTL8255 OUTii, L2 BR djnz, A VID_MEM $02 + m) ld, B A ld, A VID_MEM m) ld, A B sub, IFNZ, VID_MEM m) A ld, B 23 i) ld, HL inc, B 23 i) ld, BEGIN, BR djnz, HL VID_MEM $06 + m) ld, B VID_SCN i) ld, 7 CTL8255 OUTii, 5 repeat nop, 6 CTL8255 OUTii, L1 jp, THEN, exx, BC pop, ;CODE \ Stream video frames, double scan CODE (vidfr) ( -- ) BC push, exx, C SPI_DATA i) ld, DE VID_MEM $04 + m) ld, HL VID_MEM 40 + VID_WDTH - i) ld, HL DE add, VID_MEM $06 + m) HL ld, DE VID_WDTH 24 - i) ld, B VID_SCN i) ld, LSET L1 BEGIN, 6 CTL8255 OUTii, HL DE add, 7 CTL8255 OUTii, A B ld, DE dec, DE -25 i) ld, 24 repeat outi, AF push, DE inc, 6 CTL8255 OUTii, HL DE add, 7 CTL8255 OUTii, AF pop, DE VID_WDTH 24 - i) ld, 24 repeat outi, B A ld, BR djnz, B 0 i) ld, B 0 i) ld, B 0 i) ld, B VID_VBL 1 - i) ld, FJR jr, LSET L2 A VID_VBL 1 - i) ld, FJR jr, FMARK FMARK A B ld, B 28 i) ld, BEGIN, BR djnz, HL inc, B A ld, 7 CTL8255 OUTii, 5 repeat nop, 6 CTL8255 OUTii, L2 BR djnz, A VID_MEM $02 + m) ld, B A ld, A VID_MEM m) ld, A B sub, IFNZ, VID_MEM m) A ld, B 23 i) ld, HL inc, B 23 i) ld, BEGIN, BR djnz, HL VID_MEM $06 + m) ld, B VID_SCN i) ld, 7 CTL8255 OUTii, 5 repeat nop, 6 CTL8255 OUTii, L1 jp, THEN, exx, BC pop, ;CODE \ PS2 keyboard driver subsystem PSK_MEM CONSTANT PSK_STAT PSK_MEM $02 + CONSTANT PSK_CC PSK_MEM $04 + CONSTANT PSK_BUFI PSK_MEM $06 + CONSTANT PSK_BUFO PSK_MEM $08 + CONSTANT PSK_BUF PC XORG $39 + T! ( RST 38 ) di, AF push, $10 SIOA_CTL OUTii, A SIOA_CTL i) in, A 4 bit, IFZ, AF pop, ei, reti, THEN, ( I1 - T1 ) A PSK_MEM m) ld, A A or, IFZ, A PTC8255 i) in, A 7 bit, ( I1 - ) IFZ, A 1 i) ld, PSK_MEM m) A ld, THEN, ( I2 - T2 ) AF pop, ei, reti, THEN, ( - T1 ) A $9 i) cp, FJR CNZ jrc, TO L3 HL push, HL PSK_MEM $02 + m) ld, H 8 i) ld, clrA, BEGIN, L rrc, A 0 i) adc, H dec, BR CNZ jrc, H A ld, A PTC8255 i) in, A H ld, A 0 i) adc, A $1 i) and, FJR CZ jrc, TO L1 clrA, VID_MEM m) A ld, VID_MEM $02 + m) A ld, A PSK_MEM $04 + m) ld, L A ld, A PSK_MEM $06 + m) ld, A inc, A PS2_BMSK i) and, A L cp, FJR CZ jrc, TO L1 PSK_MEM $06 + m) A ld, L A ld, A PSK_MEM $08 + <<8 >>8 i) ld, A L add, L A ld, A PSK_MEM $08 + >>8 i) ld, A 0 i) adc, H A ld, A PSK_MEM $02 + m) ld, (HL) A ld, L1 FMARK clrA, PSK_MEM m) A ld, HL pop, AF pop, ei, reti, L3 FMARK A PTC8255 i) in, rlca, A PSK_MEM $02 + m) ld, rra, PSK_MEM $02 + m) A ld, A PSK_MEM m) ld, A inc, PSK_MEM m) A ld, AF pop, ei, reti, CODE (pskset) di, $11 SIOA_CTL OUTii, $19 SIOA_CTL OUTii, im1, ei, ;CODE : PSK< ( -- n ) PSK_BUFI @ PSK_BUFO @ = IF 0 ELSE PSK_BUFI @ 1+ [ PS2_BMSK LITN ] AND DUP PSK_BUF + C@ SWAP PSK_BUFI ! THEN ; : PSKV< ( -- n ) PSK_BUFI @ PSK_BUFO @ = IF BEGIN 1 VD_DECFR ! (vidfr) PSK_BUFI @ PSK_BUFO @ = NOT UNTIL THEN PSK_BUFI @ 1+ [ PS2_BMSK LITN ] AND DUP PSK_BUF + C@ SWAP PSK_BUFI ! ; : PSK$ ( -- ) 0 PSK_BUFO ! 0 PSK_BUFI ! 0 PSK_STAT ! (pskset) ; : (ps2kc) 0 BEGIN DROP PSKV< DUP 5 = IF 0 VD_CURCL ! DROP 0 THEN DUP 6 = IF VD_CURCL @ 4 < IF 0 ELSE VD_CURCL @ 4 - THEN VD_CURCL ! DROP 0 THEN DUP 4 = IF VD_CURCL @ [ VID_WDTH 28 - LITN ] > IF [ VID_WDTH 24 - LITN ] ELSE VD_CURCL @ 4 + THEN VD_CURCL ! DROP 0 THEN DUP UNTIL ; \ playing with FDC 179x's READ ADDRESS cmd. \ needs B380 macros and B382's L2 \ read 26 ID fields and write their 26*6 bytes to a CODE FDADDR ( trk a -- st ) \ st=status byte w/ error-only mask DE PUSH, BC>HL, A $81 LDri, $f4 OUTiA, fdwait DI, D 26 LDri, BEGIN, $c4 fdcmd BC $06f3 LDdi, BEGIN, BEGIN, fdstat $b6 ANDi, Z? BR ?JRi, \ DRQ $b4 ANDi, IFZ, TO L3 ( error ) INI, Z? ^? BR ?JRi, fdwait D DECr, Z? ^? BR ?JRi, ( A from fdwait ) $3c ANDi, L3 FMARK EI, A>BC, DE POP, ;CODE CODE FDSEEK ( trk -- st ) A 21 LDri, C CPr, A $81 LDri, IFC, $20 ORi, ( WP ) THEN, $f4 OUTiA, A B LDrr, ( trk ) $f3 OUTiA, $18 fdcmd fdwait $98 ANDi, C A LDrr, B 0 LDri, ;CODE : INIR, $edb2 M, ; CODE FDTRK@ ( a -- st ) \ st=status byte w/ error-only mask BC>HL, A $81 LDri, $f4 OUTiA, fdwait \ DI, $e4 fdcmd C $f3 LDri, \ BEGIN, fdstat 2 ANDi, Z? BR ?JRi, \ DRQ \ INIR, INIR, INIR, INIR, INIR, fdstat EI, A>BC, ;CODE \ LSET L1 INI, \ LSET L2 fdstat RRA, RRA, C? L1 BR ?JRi, ( DRQ! ) \ RLA, C? L2 BR ?JRi, \ RLA, $3c ANDi, EI, A>BC, ;CODE : INIR, $edb2 M, ; CODE FDTRK@ ( a -- st ) \ st=status byte w/ error-only mask BC>HL, A $81 LDri, $f4 OUTiA, fdwait DI, $e4 fdcmd C $f3 LDri, BEGIN, fdstat 2 ANDi, Z? BR ?JRi, \ DRQ INIR, INIR, INIR, INIR, INIR, INIR, INIR, INIR, INIR, \ fdstat RRA, C? BR ?JRi, fdstat EI, A>BC, ;CODE \ INIR, INIR, INIR, INIR, INIR, fdstat EI, A>BC, ;CODE \ LSET L1 INI, \ LSET L2 fdstat RRA, RRA, C? L1 BR ?JRi, ( DRQ! ) \ RLA, C? L2 BR ?JRi, \ RLA, $3c ANDi, EI, A>BC, ;CODE \ xcomp for my TRS80 4P. 3 CONSTS $f300 RS_ADDR $f3fa PS_ADDR 0 HERESTART RS_ADDR $90 - VALUE SYSVARS SYSVARS $80 + VALUE DRVMEM SYSVARS $409 - VALUE BLK_MEM DRVMEM VALUE KBD_MEM DRVMEM 3 + VALUE GRID_MEM DRVMEM 6 + VALUE FDMEM DRVMEM 9 + VALUE MSPAN_MEM DRVMEM 10 + VALUE UNDERCUR DRVMEM 11 + VALUE RXTX_MEM \ ARCHM XCOMP Z80A TRS804PM \ XCOMPC Z80C COREL TRS804P ALIAS FD@ (ms@) ALIAS FD! (ms!) CREATE (msdsks) 100 C, 100 C, 100 C, 180 C, 180 C, 0 C, \ MSPANSUB BLKSUB GRIDSUB RXTXSUB : INIT GRID$ KBD$ BLK$ MSPAN$ FD$ $e CL$ ; \ XWRAP \ trying out new TO semantics CREATE to? 0 C, PC ( lblval ) HL to? LD, (HL) 0 BIT, IFZ, ( read ) HL POP, BC PUSH, LDBC(HL), ;CODE THEN, ( write ) (HL) 0 RES, HL POP, (HL) C LD, HL INC, (HL) B LD, BC POP, ;CODE CODE to A 1 LD, (to?) A LD, ;CODE CODE fooval ( lblval ) CALL, $1234 ,
+\ No newline at end of file
