colorforth jul31 chuck moore public domain 24 load 26 load 28 load 30 load
dump 32 load ;
icons 34 load ;
print 38 load ;
file 44 load ;
north 46 load ;
colors 56 load ; mark empty

macro
swap 168b 2, c28b0689 , ;
0 ?dup c031 2, ;
if 74 2, here ;
-if 79 2, here ;
a ?dup c28b 2, ;
a! ?lit if ba 1, , ; then d08b 2, drop ;
2* e0d1 2, ;
a, 2* 2* , ;
@ ?lit if ?dup 58b 2, a, ; then 85048b 3, 0 , ;
! ?lit if ?lit if 5c7 2, swap a, , ; then 589 2, a, drop ; then a! 950489 3, 0 , drop ;
nip 4768d 3, ;
+ ?lit if 5 1, , ; then 603 2, nip ;
or 633
binary ?lit if swap 2 + 1, , ; then 2, nip ;
and 623 binary ;
u+ ?lit if 681 2, , ; then 44601 3, drop ;
? ?lit a9 1, , ;

pentium macros: 1, 2, 3, , compile 1-4 bytes
drop lodsd, flags unchanged, why sp is in esi
over sp 4 + @
swap sp xchg
0 0 0 xor, macro 0 identical to number 0
a 2 0 mov, never used?
a! 0 2 mov, unoptimized
@ eax 4 *, unoptimized
! edx 4 *
nop used to thwart look-back optimization
- ones-complement
2*
2/
if jz, flags set, max 127 bytes, leave address
-if jns, same
then fix address - in kernel
push eax push
pop eax pop
u+ add to 2nd number, literal or value
? test bits, set flags, literal only!

macros
over ?dup 4468b 3, ;
push 50 1, drop ;
pop ?dup 58 1, ;
- d0f7 2, ;
for push begin ;
*next swap
next 75240cff
0next , here - + 1, 4c483 3, ;
-next 79240cff 0next ;
i ?dup 24048b 3, ;
*end swap
end eb 1, here - + 1, ;
+! ?lit if ?lit if 581 2, swap a, , ; then 501 2, a, drop ; then a! 950401 3, 0 , drop ;
nop 90 1, ;
align here - 3 and drop if nop align ; then ;
or! a! 950409 3, 0 , drop ;
* 6af0f 3, nip ;
*/ c88b 2, drop f9f72ef7 , nip ;
/mod swap 99 1, 16893ef7 , ;
/ /mod nip ;
mod /mod drop ;

for n push count onto return stack, falls into begin
begin -a current code address - byte
*next aa-aa swap for and if addresses
next a decrement count, jnz to for, pop return stack when done
-next a same, jns - loop includes 0
i -n copy loop index to data stack
end a jmp to begin
+! na add to memory, 2 literals optimized
align next call to end on word boundary
or! na inclusive-or to memory, unoptimized
* mm-p 32-bit product
*/ mnd-q 64-bit product, then quotient
/mod nd-rq remainder and quotient
/ nd-q quotient
mod nd-r remainder
time -n pentium cycle counter, calibrate to get actual clock rate

compiled macros
2/ f8d1 2, ;
time ?dup 310f 2, ; forth
@ @ ;
! ! ;
+ + ;
*/ */ ;
* * ;
/ / ;
2/ 2/ ;
dup dup ; arithmetic
negate - 1 + ;
min less if drop ; then swap drop ;
abs dup negate
max less if swap then drop ;
v+ vv-v push u+ pop + ;
writes acn for write next drop drop ;
reads acn for read next drop drop ;
oadf qwerty
save 0 dup nc @ writes stop ;

these macros may be white, others may not
@ etc arithmetic
negate n-n when you just cant use -
min nn-n minimum
abs n-u absolute value
max nn-n maximum
v+ vv-v add 2-vectors
nc -a number of cylinders booted
save write colorforth to bootable floppy
oadf save as spelled by qwerty. for typing with blank screen

colors etc
block 100 * ;
white ffffff color ;
red ff0000 color ;
green ff00 color ;
blue ff color ;
silver bfbfbf color ;
black 0 color ;
screen 0 dup at 1024 768 box ;
5* 5 for 2emit next ;
cf 25 dup at red 1 3 c 3 a 5* green 14 2 1 3 3e 5* ;
logo show black screen 800 710 blue box 600 50 at 1024 620 red box 200 100 at 700 500 green box text cf keyboard ;
empty empt logo ;

block n-a block number to word address
colors specified as rgb: 888
screen fills screen with current color
at xy set current screen position
box xy lower-right of colored rectangle
dump compiles memory display
print compiles screen print
icon compiles icon editor
logo displays colorforth logo
show background task executes following code repeatedly
keyboard displays keypad and stack

dump x 2097152 y 2101760
one dup @ h. space dup h. cr ;
lines for one -1 + next drop ;
dump x !
r show black screen x @ 15 + 16 text lines keyboard ;
it @ + @ dup h. space ;
lines for white i x it i y it or drop if red then i . cr -next ;
cmp show blue screen text 19 lines red x @ h. space y @ h. keyboard ;
u 16
+xy dup x +! y +! ;
d -16 +xy ;
ati f4100000 ff7fc000 or
byte 4 / dump ;
fix for 0 over ! 1 + next ; dump

does not say empty, compiles on top of application
x -a current address
one a-a line of display
lines an
dump a background task continually displays memory
u increment address
d decrement
ati address of agp graphic registers
byte a byte address dump
fix an-a test word

icons empty macro
@w 8b66 3, ;
!w a! 28966 3, drop ;
*byte c486 2, ; forth ic 0 cu 351
sq xy @ 10000 /mod 16 + swap 16 + box 17 0 +at ;
loc ic @ 16 24 8 */ * 12 block 4 * + ;
0/1 8000 ? if green sq ; then blue sq ;
row dup @w *byte 16 for 0/1 2* next drop -17 16 * 17 +at ;
ikon loc 24 for row 2 + next drop ;
adj 17 * swap ;
cursor cu @ 16 /mod adj adj over over at red 52 u+ 52 + box ;
ok show black screen cursor 18 dup at ikon text ic @ . keyboard ; 36 load ok h

draw big-bits icon
@w a-n fetch 16-bit word from byte address
!w na store same
*byte n-n swap bytes
ic -a current icon
cu -a cursor
sq draw small square
xy -a current screen position, set by at
loc -a location of current icons bit-map
0/1 n-n color square depending on bit 15
row a-a draw row of icon
+at nn relative change to screen position
ikon draw big-bits icon
adj nn-nn magnify cursor position
cursor draw red box for cursor
ok background task to continually draw icon, icon number at top sr 4210752 4210752 4210752

edit
+ic 1 ic +! ;
-ic ic @ -1 + 0 max ic ! ;
bit cu @ 2/ 2/ 2/ 2/ 2* loc + 10000 cu @ f and 1 + for 2/ next *byte ;
toggle bit over @w or swap !w ;
td toggle
d 16
wrap cu @ + 16 24 * dup u+ /mod drop cu ! ;
tu toggle
u -16 wrap ;
tr toggle
r 1 wrap ;
tl toggle
l -1 wrap ;
nul ;
h pad nul nul accept nul tl tu td tr l u d r -ic nul nul +ic nul nul nul nul nul nul nul nul nul nul nul nul 2500 , 110160c dup , , 2b000023 , 0 , 0 , 0 ,

edit icon

png empty w 54 h 32 d 4
frame 1e80000 ; file 42 load 40 load
-crc a here over negate + crc . ;
crc -crc ;
wd -a here 3 and drop if 0 1, wd ; then here 2 2/s ;
bys n-a . here swap , ;
plte 45544c50 48 bys 0 3, ff0000 3, ff00 3, ffff00 3, ff 3, ff00ff 3, ffff 3, ffffff 3, 0 3, c00000 3, c000 3, c0c000 3, c0 3, c000c0 3, c0c0 3, c0c0c0 3, crc ;
png awh d @ / h ! d @ / w ! wd swap 474e5089 , a1a0a0d , ihdr 52444849 13 bys w @ . h @ . 304 , 0 1, crc plte idat 54414449 0 bys swap deflate crc iend 444e4549 0 bys crc wd over negate + ;
at 1024 * + 2* frame + ;
full 4 d ! 0 dup at 1024 768 png ;
pad 1 d ! 46 -9 + 22 * nop 25 -4 + 30 * at 9 22 * nop 4 30 * png ;

lz77 macro
@w 8b66 3, ;
*byte c486 2, ;
!b a! 289 2, drop ; forth
*bys dup 16 2/s *byte swap ffff and *byte 10000 * + ;
. *bys , ;
+or over - and or ;
0/1 10 ? if 1e and 1e or drop if 7 ; then f ; then 0 and ;
4b dup 0/1 9 and over 6 2/s 0/1 a and +or swap 11 2/s 0/1 c and +or 8 or ;
pix dup @w d @ 2* u+ 4b ;
row 1, dup w @ 2/ dup 1 + dup 2, - 2, 0 dup 1, +adl for pix 16 * push pix pop or dup 1, +adl next drop +mod d @ 1024 2 * * + ;
deflate 178 2, 1 0 adl! h @ -1 + for 0 row next 1 row drop ad2 @ *byte 2, ad1 @ *byte 2, here over 4 + negate + *bys over -4 + !b ;

crc macro
2/s ?lit e8c1 2, 1, ;
1@ 8a 2, ; forth ad1 48546 ad2 48600
array -a pop 2 2/s ;
bit n-n 1 ? if 1 2/s edb88320 or ; then 1 2/s ;
fill nn for dup 8 for bit next , 1 + next drop ;
table -a align array 0 256 fill
crc an-n -1 swap for over 1@ over or ff and table + @ swap 8 2/s or 1 u+ next - nip ;
+adl n ff and ad1 @ + dup ad2 @ +
adl! ad2 ! ad1 ! ;
+mod ad1 @ 65521 mod ad2 @ 65521 mod adl! ;

dos file
blks 256 * ;
w/c 18 blks ;
buffer 604 block ;
size -a buffer 0 1 reads buffer 98f + ;
set n ! buffer 0 1 writes ;
cyls n-nn 1 swap w/c -1 + + w/c / ;
put an dup 2* 2* size set cyls writes stop ;
get a size @ 3 + 2/ 2/ cyls reads stop ;
.com 0 63 blocks put ;

blks n-n size in blocks to words
w/c -n words per cylinder
buffer -a 1 cylinder required for floppy dma
size -a locate size of 2nd file. floppy has first filler then file allocated. filler is 2048 bytes, to fill out cylinder 0. names at most 8 letters, all caps. directory starts at buffer 980 +
set n size. file must be larger than your file.
cyls n-nn starting cylinder 1 and number of cylinders
put an write file from address
get a read file to address

north bridge empty macro
4@ dup ed 1, ;
4! ef 1, drop ; forth dev 15104
nb 0 dev ! ;
sb 3800 dev ! ;
agp 800 dev ! ;
ess 6800 dev ! ;
ric 7800 dev ! ;
win 8000 dev ! ;
ati 10000 dev ! ;
add cf8 a! 4! cfc a! ;
q 80000000 + add 4@ ;
en 8004 q -4 and or 4! ;
dv dup 800 * q swap 1 + ;
regs dev @ 19 4 * + 20 for dup q h. space dup h. cr -4 + next drop ;
devs 0 33 for dup q dup 1 + drop if dup h. space drop dup 8 + q dup h. space over h. cr then drop 800 + next drop ;
ok show black screen text regs keyboard ;
u 40 dev +! ;
d -64 dev +! ;
test ff00 + a! 4@ ; ok

ascii macro
1@ 8a 2, ; forth
string pop ;
cf-ii string 6f747200 , 696e6165 , 79636d73 , 7766676c , 62707664 , 71757868 , 336a7a6b , 37363534 , 2d313938 , 2f322e30 , 2b213a3b , 3f2c2a40 ,
ch fffffff0 and unpack cf-ii + 1@ ff and ;
ii-cf string 2a00 , 0 , 2b2d0000 , 2725232e , 1b262224 , 1f1e1d1c , 28292120 , 2f000000 , 3a43355c , 3d3e3440 , 484a3744 , 3336393c , 38314742 , 3f414632 , 493b45 , 0 , a13052c , d0e0410 , 181a0714 , 306090c , 8011712 , f111602 , 190b15 ,
chc ffffffe0 + ii-cf + 1@ ff and ;

clock macro
p@ ec 1, ;
p! ee 1, drop ; forth
ca 70 a! p! 71 a! ;
c@ ca 0 p@ ;
c! ca p! ;
hi 10 c@ 80 and drop if ; then hi ;
lo 0 p@ 80 and drop if lo ; then ;
bcd c@ 16 /mod 10 * + ;
hms0 4 bcd 100 * 2 bcd + 100 * 0 bcd + ;
hms hms0 2 ms dup hms0 or drop if drop hms ; then ;
ymd 9 bcd 100 * 8 bcd + 100 * 7 bcd + ;
day 6 c@ -1 + ;
cal hi lo time - hi lo time + 748 ;

lan empty 3f8 54 load init
no block 4 * 1024 ;
send no for dup 1@ xmit 1 + next drop ;
receive no for rcv over 1! 1 + next drop ;
no 18 7 18 * ;
backup no for dup send 1 + next drop ;
accept no for dup receive 1 + next drop ;

sr 4210752 4210752 4210752

serial 3f8 2e8 1050 macro
p@ a! dup ec 1, ;
p! a! ee 1, drop ;
1@ 8a 2, ;
1! a! 288 2, drop ; forth
r 0 + + ;
9600 12 ;
115200 1 ;
b/s 83 3 r p! 9600 0 r p! 0 1 r p! 3 3 r p! ;
init b/s 16550 1 2 r p! 0 4 r p! ;
xmit n 5 r p@ 20 and drop if 0 r p! ; then pause xmit ;
cts 6 r p@ 30 and 30 or drop if cts ; then xmit ;
st 6 r p@
xbits 30 and 10 / dup 1 and 2* 2* + 2/ ;
st! 4 r p! ;
?rcv 5 r p@ 1 and drop if 0 r p@ then ;
rcv ?rcv if ; then pause rcv ;

p@ p-n fetch byte from port
p! np store byte to port
1@ a-n fetch byte from byte address
1! na store byte to byte address
r n-p convert relative to absolute port address. base port on stack at compile time. compiled as literal at yellow-green transition
9600
115200 baud-rate divisors. these are names, not numbers
b/s set baud rate. edit to change
init initialize uart
xmit n wait for ready and transmit byte
cts n wait for clear-to-send then xmit
st -n fetch status byte
xbits n-n exchange status bits
st! n store control byte
?rcv fetch byte if ready. set flag to be tested by if
rcv -n wait for ready and fetch byte

hexagon empty col 0 del 2105376
lin dup 2/ 2/ dup 2* line ;
hex xy @ 7 and over 2/ for lin 7 + next over for lin next swap 2/ for -7 + lin next drop ;
+del del @ nop
petal and col @ + f8f8f8 and color 100 hex ;
-del del @ f8f8f8 or 80808 + ;
rose 0 +del -176 -200 +at f80000 -del petal 352 -200 +at f80000 +del -264 -349 +at f800 -del petal 176 -200 +at f8 +del -176 98 +at f8 -del petal 176 -200 +at f800 +del ;
ok show black screen 512 282 at rose text col @ h. space del @ ff and . keyboard ; 58 load ok h

draws 7 hexagons. colors differ along red, green and blue axes.
col color of center hexagon
del color difference
lin n draws 1 horizontal line of a hexagon
hex n draws top, center and bottom. slope 7 x to 4 y is 1.750 compared to 1.732
+del n increment color
-del n
petal n draw colored hexagon
rose draw 7 hexagons
ok describe screen. center color at top

pan
in del @ 2* 404040 min del ! ;
out del @ 2/ 80808 max del ! ;
r f80000
+del del @
+col and col @ + f8f8f8 and col ! ;
g f800 +del ;
b f8 +del ;
-r f80000 -del +col ;
-g f800 -del +col ;
-b f8 -del +col ;
nul ;
h pad nul nul accept nul -r -g -b nul r g b nul out nul nul in nul nul nul nul nul nul nul nul nul nul nul nul 250000 , 130d01 dup , , 2b000023 , 0 , 0 , 0 ,

in increment color difference
out decrement it
r
g
b increment center color
-r
-g
-b decrement it
+del redefine with ;
+col change center color
nul ignore
h describe keypad

timing empty macro
out e1e6 2, ; forth
tare time - 1000 for next time + ;
tare+ time - push 1000 for dup next c pop time + ;
test tare time + - 1000 for out next time + ; next 3 loop 5.7 /next 2 /swap 25 swap 7.2 macro
c! c88b 2, drop here ;
loop 49 1, 75 1, e2 here - + 1, ; forth
try time - 1000 c! loop time + ;

io
io
io at
io
io
io a t a 32897 r rro ac 10111e t n;dup?dupdropthenbeginswap0if-ifaa!2*a,@!nip+orbinaryandu+?overpushpop-for*nextnext0next-nexti*endend+!nopalignor!**//mod/mod2/timep@p!hd astbootwarmpausemacroforthcstopreadwritenccommanseekreadyactshowloadhere?lit3,2,1,,lessjumpacceptpaderasecopymarkemptemitdigit2emit.h.h.ncrspacedowneditelmrmgraphtextkeybodebuat+atxyfovfifoboxlinecoloroctantsplastunpac@!+*/*/2/dupnegateminabsmaxv+writesreadsoadfsaveblockwhiteredgreenbluesilveblackscreen5*cflogoemptydumpiconsprintfilenorthcolorsblksw/cbuffesizesetcylsputget.comformat

ns 4da ed 6c5 r ml r md 1050902 r ce r cn r cd r c8 1051013 r ys r le r ln r ld
r l8 r gt 32853 r gl r g8 r f 8058 r fe 1051451 1051467 100b7a r w r wt
r we
r ws r v r vs r ps r bs 1051792 8065 r us 1051887

r qs 803a r in 1362 r6s 724 34 822 ri 543 to 243 19 te ti t; or ie nd 36 ns ns ni na ir io tec 1dd6 r7 oo 865 9993 10106 2723 10f t r tri 11319 tvs ttr ttr r! 8285 ttl r8s ttr ttt
r-s r-s r! t c t i rzs tto rk rks tid 100d1a 32873 r 1 1051959 r 1s r 2 r 2s 806a r 2s r 3 r 3s 32876 r 4s 32877 806d 806d r 6s 1052141 r 7s 1052171 r 8s r 9 8071 r j r -s r k r ;s r , r , r ,s r ? 1052667 r r r r r 32897 r r o r r e r r e r r i 1052883 101119 r ms

ne-i!d hea?w gltos8 d,tt2 dry gd
ggi.i8
qp ; - yse @ea?, an gqd tge nf-n s r wtlwu tgerenlv3e rjl ad tfl
inml lt 0y8 709 r/ers; ml 344fe3 489f42inml lt 0y8 718 18471,ofml beasns m;8deac8 3 o;
o ef mo@ins 26048mw d 344fe3 3cadinmw d w 0y8 1945
,ofmw 36 rl vs mo@ins 1009088crsd rk!s +8 ot 1711851713 dstkn -12189642
wso e 1989001984 w 0y8 16777215 -289 r.ear@v3e qpdver+d wrs*l -67108736 r.s,ofml 8! rl ta??,?s o
skgl -512407296
?kiln em i?; rdt ris 1988953521 k oee@ -76 reie sn eker0 mwgwae 344fe3 -769 ;i er@
r.tagw .l
oamngf r. ls+rnl wt t n
aj,c@ ?;5id aeo4a@ mn t hvayn hyo ti ??@o 4es

r.s s rcas?8eoo tict gs+ro8 ml e o0rwcn 7840
s23on r wos0fnnn oio8 bdp; -2035456317 r wos8nm
mturai aimtur 2048 1358923 -65536000 iaec y ?!o @ an doagta frrldk rs ???/ r.e gsrmitar -825 8nodid ac ag8iae soagics 369098752aianvs 3000b08donk mi??@ 18b900ktm fc0c781ecfe 5405815e rgl f
?oeien ab?, f2
rj8ri o!atks k ???6 8keol hea,es r.eagnu:s rjl a;gffs
?na!o ro7?d
is -930414592 r.s 1ori8 e rok nis e ndgcss tc t -36645904 e 9nmrnt r.ea kagr
ognu; iaecfid v3nf@ mo@ins -5766!e mw??; 344fe3 fff807fd,-wes inmw?8 w 0y8 12632256 ??n?d ,ofmwd ?6 rlks e e???fd mo@ins 1472 lo1 ; mw??; 344fe3 7f805,hwed ?@ o lel gitgsml treto riiml
lewgtis tre 1989002157 wt 0y8 11 treto4dry
v3ngis mo@ins -36793960 r vea@id i?t8l
ramt rjs 1962934272 mw 0 344fe3
aelis d k s???ls mo@ins 2098624inml w 0y8 768 ??fni asrft, ds r ddprd
ae 4es mt t r-mnuvs rjf 15y rjs 227219832 f2 nnr 88 rjl 4ddd ae 4em vs r
rjpslis.l rjs -1553546323 rjs anlnul gl e
a rnnd rjs a rnnl f2 inmw k w 0y8 67 slrral 45689da rnof tn eoe ti
uod; 71,3il /d?? ewttmgee 344fe3
eimas d a?etos ay??@ v!6g ykeefpmamn -1928236230 344fe3 /dd; ex!j!d
,3*rs o4a?, 123 mo@ins 19154184rrk b??? 1989637 o!as wrd o0 s
bs 1023576832
?wik itki?d ki??8 ???z -2033 ae aso8 rmn f teivs uodd of?f k ab?, f2
45100603 o r?g/e bfn?@ -1929229568 tro9s witt?es 7??8 re d s 303107849 a i 8
rirn e rct tls rd 4e r;disstcajrt 20013393 421735207 rd 4e r;diss trt

rc rd 4e r;diss trt 918544od mnrt; 10048a00
rtrrr d
e r 335544320 a090800 rloto d s r ;iml srs 344fe3
z!o d ji??l ie rg d 3cef74f0 ma3ioo tolodea8d tec 9372 tec 9864 a tac 250b tnf 249c tec 9768 tnc t1 s tac 250b 2958613 tec 9758 tns ta0
8tc 9720 tni 9493 too teo 10 tal ??d 948
io bmn.0 2369536o:zoe
mt e teisn?crk eoq?d trwrtramn tei 125969663
ftlo t odn!dfo.ior ie ma
rsnm e kpfss 1265869 s-ttitkns ;iajid
nortn0 19290217masd texs edd
knrcn0 ???, kienr0 ???? -888814080 rd r 19290473veas mo@ins 25118232 lo??@ 9368 gfrmls ??3ad , -lis ab?, 124 temsri rinml bsnmo8 6xsab rd r -3721 mnrt:; 8224ff00 raiede mo@ins -2228416 e ki?d ???? 1021881600 .??? s wr; l ebs 2379776is wrd n; r
vs t tes w r abs tei 9296 teis wtos8sosd 6100ntoas t; r tessaidt7as lr1gfs /??8 d 0 is f e o t 497156105 -11010047 ?a3a tessaid ab tnrkn ry ???fe -5353 mnrt:; 8224ff00 2wede ta*dt a+ tnr +stier 78b45e tes tfs0 rs b3eal 2384896gf:3 tecsaidrm1 gw??; teidt8tetso4ns too abm 8 tei 9216 toaio4k3e ???wd teidt8teodo4ns too abm 8 tei 9236 toaio4o4es 123 ??g-s idtd, re t -3353 c tw?8 ks t ???fs d8d0c8 r;;iee 319103264 8t s mo@ins -66825592 tn; -14737 d83o8inmlro sn 0y8 -1950150688mwno7l t sl -743636992.jla8 -655884288 ki??8 -1376553655
iwospie ia??, iaeyale e8ffffff -386697911 ???re .lrv0 s if @ l e 1179d285

inmwnws w 0y8 35 -15729 mio8veas
oe+kms tl;siadets/oxtee veamo8
oe+kms tl;s?lg0 icci?8 knrea;???k -15753 mw .wd 344fe3 -10566925438ersed 8nmvs 1360863 872931459 20319768 ndn s
tv?seinmw p ?snmo8 -1539491578 ia t 87752704 tge nicre8 tgas+v3e tga ift4 s rjs rn mo@ins 33555904cwl i fdc7ffff o 45116507 nn r rj8oedr is -17329 aet4 @ rvs rn ?*7od 4afn; f2 46164443 ie r -1578565633 ff4fffff c -15049 cwl@ark ff4fffff s mo@ins -522816 ty0 ; ff5fffff aet4 w r+s rn ??t! ?@o?8 noia?@ f ifta k r ??,k -1745 k3anws ???os -20657 ,ofmwd emn 0 ???cd ;i er@ -2377 krs e; -73 b! 9d 689fc76 ,akrt si??@fylis8 ie??, krs et -1545015061 689fc76 ,akrt si??@cr0;i ie??, +a ie :ia?, -18825 v3nf@ ,akat d??? rt.sa; -17193 ?9ilis remi?; finmgrd w 0y8 63488 tgos+tiilonie 60005mna,f ??t!t *n ?, 48404mgrd 344fe3 fffff805ys+ t il e ie t 434634944 689fc76 ta?8l tgt -2538264 +kilis s6m?; fc6fffff 344fe3 tgnretgarendry tge if-8e -43914168 +s t wl ; aie -4209 wlatt, ysrir0 il e + r 714868167tiec9ers clao, 151 dea8is tme tmt 10643 tsd 324 10572 2987 10460 tm8 14a
io
io
io n 31 tir rs2 !rt yrt0 a!;eowoacs tii 2 rt 4652 c8 1843 t7 ths tu tf8 tf8 tw tv twl twd 11239 2bb5 twt td
io tw tw 1843
io
io
io
io
io
io
io 2d0d010f rr rn 722077987 toli ??d ?s d ?@ ??, ??, ??, sr r8 .srf ff581d80

eb09b00e .sgn -10986112 11128 e slrt bs t 2974464temrenggn ?,ogi is wrws d r fff807fdc wrd us t .s t ,ofmwe -1070397815 tey wdsyls ?s tges?snic 763609856 tge -29862968 0 asisd tge 2891288 tge -1606581309 re t 16c1853 tge -1607105597 r t
vsrons lnnr3l tge ,ofmfs lret 0 bs t 2980352os wrs ta t tetdt8tvlnrk b??? 2824192is wrd ts e bs t -65536+grk re??, -236212992 fe3d6d6a 242688csrird oo t b 96927744 tet 9372 tem w?s 2ies ; mi??@ fa8100ia c8 .er8d 2249816 tey rfinml mn 0y8 82477826 si-iae 10932 tgn rf 0rs 124
tgn rld8de???8 4asf8 124 ,ogeye
oamngf tgn mnyfie y il , ds t 1ast8 341 ff36083b -272539908 10916 tey rfmtyd wleyal ffffff94 tf; 4 vs f+caks a+i?d 15b gl yl
soltt; -2130152196 ; dciia; 36963808tf;o4ie e 2392125 tie l abm o 124 inmfc; w 0y8 1tf;o4ie e 2392125 tie l ns9 o tey w tieks ki??8
t tgas+ 4as tgn -8ioh 10920 :st-n -1912602627 344fe3 tgaregsregs ie t cactth fd41ac5a ml s ??t2n o4a?, tgn gi@gwd ca:iae fs+roe a8 r mtffr0 8cc28100mt 10ea8300 teidgsnm0 2b7415mwe d o asel e7ebd2

?iw@i i,i?d 7800f ; is ; is ; is ; is
d r8
d r8 ,r?;n d r? d
d r8
d r8
d r8
d r8
d r8
d r8 ?o?8t r?b@8 ?s ?s ?s ?s ?s ?s fff3f8ff @ ?@8 ?o?8t ?s?osr?s ?s ,i?*8 ; is fff3f807 @ ?@8 ?o?8t r; i:d ; is ?w?@d 7f807f?w;?d +m?*d
?iw@i r?-*8 7f807f ?s ?s ?s ?s ?s ?s ?s ?s
d r8
d r8d rs
d r8
d r8
d r8
d r8
d r8
d r8 ?o?8t t@i:d ; is ?r?;8 ; is?o@i0 @ ?@8 i/;:l -1
s,rq@ i8 o; i8 o; i8 o; i8 o; ?o?8t ?b@8 ; @ ; is r; is fff3f87f @ ?@8 ?s i8 1f3e0ff @ *;n 8 o@ s r@ o8 s @ os 14680304 s rs s 8 s ; s ; s ; s ; s ; s ; s ; d o8
8 ; +w?om r?b,8 ?s ?s ?s ?s fffbf8ff ?m?*d ; is?o@i4 @ ?@8 @ r@ s ;s ;r?srs s ? o s ; s ; s ; s ; s ; s ; i8 r8 i8 o; mqrm? 7o6oys ,r?i d isoqst o vs 0 ; is ; is ; is ?w?im r?b,8 ?s ?s ?s ?s ?s ?s fffbf8ff /m?*d i8 o; -s ?s e1c0f3 osos;n 1879996446 8 o@
s os
?iw@i r?+*8 ?do, 267390960 fff7f8ff

@iw?is ; is ; is ; is ; is ; is ; is ?i?98 r?b*8 ?s ?s ?s ?s ?s ?s fff7f8ff @io?w ; is ; is ; is
?iw@is r?-*8 7f807f ?s ?s ?s ?s ?s ?s ?s ?sr?do, iv;@8 -267388897 8 o; @ ?d o-9;n 7f80ff ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s fff3f8ff @ ?@8 /w,om o?b,8 ?sr?s ?s ?s fffbf8ff /m?*d ; is ; is 8 is ?o?8t r?b@8 ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s fff3f8ff @ ?@8 8 r;
8 o; 8 t; 8 ; 8 ; 8 ; 8 ; 8 ; 8 ; 8 ; ?o?8t r?s?os ; is ; is? @id @o?@8 78007 ; is??dr8 ???? ?o?8t r?s?os ; is ; is? om; ? o? ; @ ; is?o@i, @ ?@8;is;is;is;is;is;is;is;is??,r8 ????; is; is; is; is ???? ;i?d ; is ; is@i@ od ?i?*8 ; @ ; is?o@i, @ ?@8 ?o?8t ?b@8 ; is ; is ffc7f807 ?i?*8 7f80ff ?s ?s fff3f8ff @ ?@8 ???? i ?@r; isid r;; ,
d o; r@ id rs 78007 d i ?o?8t r?b@8 ?s ?s ?s ?s fff3f8ff ?o?;n 7f80ff ?s ?s fff3f8ff @ ?@8 ?o?8t r?b@8 ?s ?s ?s ?s fffbf8ff /m?*d ; is ; is?o@i, @ ?@8is ;is ;isis ;is ;is ;is ;is ;is ; ; ?8t -1073221617?w; ?i?,8 ?is ; is ; is ; is,isoqs
8i?:8 ?dod di@ od ,iy;iso?s?@ o; i@ 30720 s o; r n ???? r; i?d? r@
8 i, ?e rs fffff807 ????r; iso8 @id o8; , 8 r@ d o8 r@ o8 s id os 16253176

i d , d ? e is i d , d ? e s ;
is rd i d , d ? e is i d , d ? e is d rd
8 o8 8 o; 8 o;
d r8 s o s
d r8
d r8
d r8
d r8
?o? ?o?@8 d r?ys
d r8
d r8 ?o?8t ?s?os i8 o; -;;,
-;@,
?ir?@
@i ?w 8 i?o@o, @ ?@8o s ; :8t -1073225713
; o; osoqs r 0 i d , d ? e d o8
is rd ?o?8t ?s?os i ii8 is @ ?s
d r;
d
d r8
d r8 ,i?v8 ?o?*8 ?m?@d ?si?s
?sr?s?s ?s?s ?s ?so?s ?s?@ ?y?@e ?i?@8 ;i?:8 ?i?98 ???7 ?sr?s ?s ?s??b? ?i?*8 di?98 ;iy8is ,is@iso?si/s ?sr?s ???? ????
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8 ?o?8t ???q 7f80ff ?s ?s ?s ?s ?s ?s ?s ?s ?s ?sr?do, ?o??8 @ ?@8 ???? ???? ; is ; is8i@ od 8i?sis ;i is ; is ; is ???? ???? s o
d r8 8 o; ; i; i -s @ *8t ,r?8t rvb;n 7380f3 ?s ?s i8 o; 7fe07f ?;o, 268374014 ?w ?s m?om?
q@:? /@io,/@ow@i?s?@o?si?sr?so?s
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8 ?o?8t ???q 7801f ; is ffc7f807 ?o?@8 r; i@e ; isr, is ?o??8 @ ?@8 i8 o;r?do, 1ffe0ff ii/o?d -:@,
s,rb; i8 o; i8 o; i8 o; i8 o; i8 o; ?o?8t ???q 7f80ff ; is ; is ; is ; is ; isr?do, ?o??8 @ ?@8 ?s i8r-do, 1e1e0f3 isobvs -267390961 d r;
d r8
d r8
d r8
d r8
d r8 ; is ; is ; is ; is ; is ; is ; is ; is ; is ???? ???? ?o?8t ???q 7f80ff ; is

; iso?s ;o?so?s ?s ?sr?do, ?o??8 @ ?@8 ???? ???? ; is ; is8i@ od 8i?sis ;i is ; is ; is ; is ; is i8 r8 i8 o; -s i8 -s -s -s -s mqrmq 6r6i d ,r?;n iso7st osos8t 404232216 @i?sis ?i?:8r?so/s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?so/sr?s ,i?*8 8i?98 i8 o; ?s ?sr?do, f3c0ff o-8@8 1010580540 isoqst ; i@ 8 o;
d r8 s o ?i?98 ???7 ?sr?s ?s ?s??b? ?i?*8 ;ibd ; is ; is ; is ; is @i?sis ?i?:8r?so/s ?s ?s?i@i, ,i?:8 r?s?is ?s ?so/sr?s ,i?*8 8i?98 ?s ?s ?s ?s ?s ?s ?s ?s??v? ???? ?s?@ ?s ?s ?s ?s ?s ?s ?s ?s ?s i8 f3c0ff iv;@8 -132155362 8 o@ 8 o; ; i; iso7st o-9;n ffc0f3 i8 i@ ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?sr?do, ?o??8 @ ?@8 ?o?8t ???q 7f80ff ?s ?s ?s ?s ?s ?s ?s ?s/@oo,o?v?8 ?o??8 *m?*d ?o?8t ?o?@8 i8 o; i8 o; i8 o; i8 o; i8 o; i8 o; i8 o; i8 o; ?o?@8 @ ?@8 s o s o s o s o s o s o s o s o s o s o s o s o ?o?8t ?o?@8 i8 o; i i i i ?o?@t @o?@8 8 i 8 i 8 i ???? ???? ?o?8t ?o?@8 i8 o; i i i i ? o?s ? o?s i i i i i8 o; ?o?@8 @ ?@88i i i8i i i8i i i8i i i8i i i ???? ????8 i8 i8 i8 i8 i ???? ???? 8 i 8 i 8 i ?i?98 ?i?*8 i i i i i8 o; ?o?@8 @ ?@8 ?o?8t ?o?@8 i8 o; 8 i 8 i ?i?98 ?i?*8 i8 o; i8 o; i8 o; ?o?@8 @ ?@8 ???? ????r8 isod ;is ;8 @ d r; s ; r8 od s 3c003 8 is ?o?8t ?o?@8 i8 o; i8 o; i8 o; ?o?@8 ?o?@8 i8 o; i8 o; i8 o; ?o?@8 @ ?@8 ?o?8t ?o?@8 i8 o; i8 o; i8 o; ?w?*d ?m?*d i i i i i8 o; ?o?@8 @ ?@8 ; is ; is ; is ; is ; is ; is ; is ; is

r?s ; ?o??8 @ ?@8 ???? ????r?s ?si/so?s ;iy@is sr?8is ? is , is 16711934 8iwsr8
@im;iso?si/s ?sr?s d rd
8 o8 d r;
s os ???? ????r; isi8 r@@ ?
8 o@ s o@ i8 rs @ is -1 ???? i o 8 osrd ;is i8 os d ;
s ; 8 rd s 3c001 8 os d i s i
s i ss t
s i
s o is 0 s i
s i ss t
s i
s o
d r8
d r8
d r8
d r8
d r8
d r8 s o s o s o s o s o s o s o s o s o ???? ???? s o s o s o s o s o ?o?8t ?o?@8 i8 o;-:d, -:@, 54473535 54473535 ?io?w 8i-s i8 i ?o?@8 @ ?@8 s o s o s o
d r8 ???? @ ?@8 8 o@ ; i; iso7 osom8t 4080c0s t
s i
s o is 0 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ; ; rs ; is ;r@ di@ ?so , is ;r@ di@ ?s , ; ; , ?s di@ ;r@ , is ?so di@ ;r@ ; is ; rs ; s t 8 os 8 os ; is ; is 8 os 8 os s t ;i?, ;i?, ;i?, ;i?,8 osd iss o8 o; i8 , @ s ; rs 8 os d is s o8 o; i8 , @
; ;i?, ;i?, ;i?, ;i?,

i;; s8 rsd oss r8 r; o8 id @ ; s 8 rs d os s r8 r; o8 id @ ;
8 d s s n d os d os d os s n s n d os d os d os s n s n ; 8 s n d os d os d os s n s n d os d os d os s n 8 os 8 os 8 os 8 os 8 os 8 os 8 os 8 os 8 os 8 os 8 os 8 os d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs ;i?, ;i?, ;i?, ;i?, d rs d rs d rs d rs d rs d rs d rs d rs d rs d rs ??d
di?, 8i?, 8i?, ; d ; ; ;is ; ;idid ;idid ;rdi ;rdi ;rdi ;rhi 8i@id 8i@id sr? ; ; d 8i?, 8i?,
di?, ??d s t s t s t d rs d rs d rs 8 os 8 os ;i?, ;i?,
di?, ??d ,r@ @ @ @ @ ,r@ ,r@ i-; o-8 r-d i8 od s n d os d os d os s n s n ; 8

di?, @i?,t od rs 234881136 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 8 os s n 134744072 4210752 colorforth jul31 chuck moore public domain 24 load 26 load 28 load 30 load
dump 32 load ;
icons 34 load ;
print 38 load ;
file 44 load ;
north 46 load ;
colors 56 load ; mark empty

macro
swap 168b 2, c28b0689 , ;
0 ?dup c031 2, ;
if 74 2, here ;
-if 79 2, here ;
a ?dup c28b 2, ;
a! ?lit if ba 1, , ; then d08b 2, drop ;
2* e0d1 2, ;
a, 2* 2* , ;
@ ?lit if ?dup 58b 2, a, ; then 85048b 3, 0 , ;
! ?lit if ?lit if 5c7 2, swap a, , ; then 589 2, a, drop ; then a! 950489 3, 0 , drop ;
nip 4768d 3, ;
+ ?lit if 5 1, , ; then 603 2, nip ;
or 633
binary ?lit if swap 2 + 1, , ; then 2, nip ;
and 623 binary ;
u+ ?lit if 681 2, , ; then 44601 3, drop ;
? ?lit a9 1, , ;

pentium macros: 1, 2, 3, , compile 1-4 bytes
drop lodsd, flags unchanged, why sp is in esi
over sp 4 + @
swap sp xchg
0 0 0 xor, macro 0 identical to number 0
a 2 0 mov, never used?
a! 0 2 mov, unoptimized
@ eax 4 *, unoptimized
! edx 4 *
nop used to thwart look-back optimization
- ones-complement
2*
2/
if jz, flags set, max 127 bytes, leave address
-if jns, same
then fix address - in kernel
push eax push
pop eax pop
u+ add to 2nd number, literal or value
? test bits, set flags, literal only!

macros
over ?dup 4468b 3, ;
push 50 1, drop ;
pop ?dup 58 1, ;
- d0f7 2, ;
for push begin ;
*next swap
next 75240cff
0next , here - + 1, 4c483 3, ;
-next 79240cff 0next ;
i ?dup 24048b 3, ;
*end swap
end eb 1, here - + 1, ;
+! ?lit if ?lit if 581 2, swap a, , ; then 501 2, a, drop ; then a! 950401 3, 0 , drop ;
nop 90 1, ;
align here - 3 and drop if nop align ; then ;
or! a! 950409 3, 0 , drop ;
* 6af0f 3, nip ;
*/ c88b 2, drop f9f72ef7 , nip ;
/mod swap 99 1, 16893ef7 , ;
/ /mod nip ;
mod /mod drop ;

for n push count onto return stack, falls into begin
begin -a current code address - byte
*next aa-aa swap for and if addresses
next a decrement count, jnz to for, pop return stack when done
-next a same, jns - loop includes 0
i -n copy loop index to data stack
end a jmp to begin
+! na add to memory, 2 literals optimized
align next call to end on word boundary
or! na inclusive-or to memory, unoptimized
* mm-p 32-bit product
*/ mnd-q 64-bit product, then quotient
/mod nd-rq remainder and quotient
/ nd-q quotient
mod nd-r remainder
time -n pentium cycle counter, calibrate to get actual clock rate

compiled macros
2/ f8d1 2, ;
time ?dup 310f 2, ; forth
@ @ ;
! ! ;
+ + ;
*/ */ ;
* * ;
/ / ;
2/ 2/ ;
dup dup ; arithmetic
negate - 1 + ;
min less if drop ; then swap drop ;
abs dup negate
max less if swap then drop ;
v+ vv-v push u+ pop + ;
writes acn for write next drop drop ;
reads acn for read next drop drop ;
oadf qwerty
save 0 dup nc @ writes stop ;

these macros may be white, others may not
@ etc arithmetic
negate n-n when you just cant use -
min nn-n minimum
abs n-u absolute value
max nn-n maximum
v+ vv-v add 2-vectors
nc -a number of cylinders booted
save write colorforth to bootable floppy
oadf save as spelled by qwerty. for typing with blank screen

colors etc
block 100 * ;
white ffffff color ;
red ff0000 color ;
green ff00 color ;
blue ff color ;
silver bfbfbf color ;
black 0 color ;
screen 0 dup at 1024 768 box ;
5* 5 for 2emit next ;
cf 25 dup at red 1 3 c 3 a 5* green 14 2 1 3 3e 5* ;
logo show black screen 800 710 blue box 600 50 at 1024 620 red box 200 100 at 700 500 green box text cf keyboard ;
empty empt logo ;

block n-a block number to word address
colors specified as rgb: 888
screen fills screen with current color
at xy set current screen position
box xy lower-right of colored rectangle
dump compiles memory display
print compiles screen print
icon compiles icon editor
logo displays colorforth logo
show background task executes following code repeatedly
keyboard displays keypad and stack

dump x 2097152 y 2101760
one dup @ h. space dup h. cr ;
lines for one -1 + next drop ;
dump x !
r show black screen x @ 15 + 16 text lines keyboard ;
it @ + @ dup h. space ;
lines for white i x it i y it or drop if red then i . cr -next ;
cmp show blue screen text 19 lines red x @ h. space y @ h. keyboard ;
u 16
+xy dup x +! y +! ;
d -16 +xy ;
ati f4100000 ff7fc000 or
byte 4 / dump ;
fix for 0 over ! 1 + next ; dump

does not say empty, compiles on top of application
x -a current address
one a-a line of display
lines an
dump a background task continually displays memory
u increment address
d decrement
ati address of agp graphic registers
byte a byte address dump
fix an-a test word

icons empty macro
@w 8b66 3, ;
!w a! 28966 3, drop ;
*byte c486 2, ; forth ic 0 cu 351
sq xy @ 10000 /mod 16 + swap 16 + box 17 0 +at ;
loc ic @ 16 24 8 */ * 12 block 4 * + ;
0/1 8000 ? if green sq ; then blue sq ;
row dup @w *byte 16 for 0/1 2* next drop -17 16 * 17 +at ;
ikon loc 24 for row 2 + next drop ;
adj 17 * swap ;
cursor cu @ 16 /mod adj adj over over at red 52 u+ 52 + box ;
ok show black screen cursor 18 dup at ikon text ic @ . keyboard ; 36 load ok h

draw big-bits icon
@w a-n fetch 16-bit word from byte address
!w na store same
*byte n-n swap bytes
ic -a current icon
cu -a cursor
sq draw small square
xy -a current screen position, set by at
loc -a location of current icons bit-map
0/1 n-n color square depending on bit 15
row a-a draw row of icon
+at nn relative change to screen position
ikon draw big-bits icon
adj nn-nn magnify cursor position
cursor draw red box for cursor
ok background task to continually draw icon, icon number at top

sr 4210752 4210752 4210752 edit
+ic 1 ic +! ;
-ic ic @ -1 + 0 max ic ! ;
bit cu @ 2/ 2/ 2/ 2/ 2* loc + 10000 cu @ f and 1 + for 2/ next *byte ;
toggle bit over @w or swap !w ;
td toggle
d 16
wrap cu @ + 16 24 * dup u+ /mod drop cu ! ;
tu toggle
u -16 wrap ;
tr toggle
r 1 wrap ;
tl toggle
l -1 wrap ;
nul ;
h pad nul nul accept nul tl tu td tr l u d r -ic nul nul +ic nul nul nul nul nul nul nul nul nul nul nul nul 2500 , 110160c dup , , 2b000023 , 0 , 0 , 0 ,

edit icon

png empty w 54 h 32 d 4
frame 1e80000 ; file 42 load 40 load
-crc a here over negate + crc . ;
crc -crc ;
wd -a here 3 and drop if 0 1, wd ; then here 2 2/s ;
bys n-a . here swap , ;
plte 45544c50 48 bys 0 3, ff0000 3, ff00 3, ffff00 3, ff 3, ff00ff 3, ffff 3, ffffff 3, 0 3, c00000 3, c000 3, c0c000 3, c0 3, c000c0 3, c0c0 3, c0c0c0 3, crc ;
png awh d @ / h ! d @ / w ! wd swap 474e5089 , a1a0a0d , ihdr 52444849 13 bys w @ . h @ . 304 , 0 1, crc plte idat 54414449 0 bys swap deflate crc iend 444e4549 0 bys crc wd over negate + ;
at 1024 * + 2* frame + ;
full 4 d ! 0 dup at 1024 768 png ;
pad 1 d ! 46 -9 + 22 * nop 25 -4 + 30 * at 9 22 * nop 4 30 * png ;

lz77 macro
@w 8b66 3, ;
*byte c486 2, ;
!b a! 289 2, drop ; forth
*bys dup 16 2/s *byte swap ffff and *byte 10000 * + ;
. *bys , ;
+or over - and or ;
0/1 10 ? if 1e and 1e or drop if 7 ; then f ; then 0 and ;
4b dup 0/1 9 and over 6 2/s 0/1 a and +or swap 11 2/s 0/1 c and +or 8 or ;
pix dup @w d @ 2* u+ 4b ;
row 1, dup w @ 2/ dup 1 + dup 2, - 2, 0 dup 1, +adl for pix 16 * push pix pop or dup 1, +adl next drop +mod d @ 1024 2 * * + ;
deflate 178 2, 1 0 adl! h @ -1 + for 0 row next 1 row drop ad2 @ *byte 2, ad1 @ *byte 2, here over 4 + negate + *bys over -4 + !b ;

crc macro
2/s ?lit e8c1 2, 1, ;
1@ 8a 2, ; forth ad1 48546 ad2 48600
array -a pop 2 2/s ;
bit n-n 1 ? if 1 2/s edb88320 or ; then 1 2/s ;
fill nn for dup 8 for bit next , 1 + next drop ;
table -a align array 0 256 fill
crc an-n -1 swap for over 1@ over or ff and table + @ swap 8 2/s or 1 u+ next - nip ;
+adl n ff and ad1 @ + dup ad2 @ +
adl! ad2 ! ad1 ! ;
+mod ad1 @ 65521 mod ad2 @ 65521 mod adl! ;

dos file
blks 256 * ;
w/c 18 blks ;
buffer 604 block ;
size -a buffer 0 1 reads buffer 98f + ;
set n ! buffer 0 1 writes ;
cyls n-nn 1 swap w/c -1 + + w/c / ;
put an dup 2* 2* size set cyls writes stop ;
get a size @ 3 + 2/ 2/ cyls reads stop ;
.com 0 63 blocks put ;

blks n-n size in blocks to words
w/c -n words per cylinder
buffer -a 1 cylinder required for floppy dma
size -a locate size of 2nd file. floppy has first filler then file allocated. filler is 2048 bytes, to fill out cylinder 0. names at most 8 letters, all caps. directory starts at buffer 980 +
set n size. file must be larger than your file.
cyls n-nn starting cylinder 1 and number of cylinders
put an write file from address
get a read file to address

north bridge empty macro
4@ dup ed 1, ;
4! ef 1, drop ; forth dev 15104
nb 0 dev ! ;
sb 3800 dev ! ;
agp 800 dev ! ;
ess 6800 dev ! ;
ric 7800 dev ! ;
win 8000 dev ! ;
ati 10000 dev ! ;
add cf8 a! 4! cfc a! ;
q 80000000 + add 4@ ;
en 8004 q -4 and or 4! ;
dv dup 800 * q swap 1 + ;
regs dev @ 19 4 * + 20 for dup q h. space dup h. cr -4 + next drop ;
devs 0 33 for dup q dup 1 + drop if dup h. space drop dup 8 + q dup h. space over h. cr then drop 800 + next drop ;
ok show black screen text regs keyboard ;
u 40 dev +! ;
d -64 dev +! ;
test ff00 + a! 4@ ; ok

ascii macro
1@ 8a 2, ; forth
string pop ;
cf-ii string 6f747200 , 696e6165 , 79636d73 , 7766676c , 62707664 , 71757868 , 336a7a6b , 37363534 , 2d313938 , 2f322e30 , 2b213a3b , 3f2c2a40 ,
ch fffffff0 and unpack cf-ii + 1@ ff and ;
ii-cf string 2a00 , 0 , 2b2d0000 , 2725232e , 1b262224 , 1f1e1d1c , 28292120 , 2f000000 , 3a43355c , 3d3e3440 , 484a3744 , 3336393c , 38314742 , 3f414632 , 493b45 , 0 , a13052c , d0e0410 , 181a0714 , 306090c , 8011712 , f111602 , 190b15 ,
chc ffffffe0 + ii-cf + 1@ ff and ;

clock macro
p@ ec 1, ;
p! ee 1, drop ; forth
ca 70 a! p! 71 a! ;
c@ ca 0 p@ ;
c! ca p! ;
hi 10 c@ 80 and drop if ; then hi ;
lo 0 p@ 80 and drop if lo ; then ;
bcd c@ 16 /mod 10 * + ;
hms0 4 bcd 100 * 2 bcd + 100 * 0 bcd + ;
hms hms0 2 ms dup hms0 or drop if drop hms ; then ;
ymd 9 bcd 100 * 8 bcd + 100 * 7 bcd + ;
day 6 c@ -1 + ;
cal hi lo time - hi lo time + 748 ;

lan empty 3f8 54 load init
no block 4 * 1024 ;
send no for dup 1@ xmit 1 + next drop ;
receive no for rcv over 1! 1 + next drop ;
no 18 7 18 * ;
backup no for dup send 1 + next drop ;
accept no for dup receive 1 + next drop ;