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 687 2, ;
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 countegas 15240000 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 25165808 y 2106224
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 67 cu 52
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 9jro@w a 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 macro
4@ dup ed 1, ;
4! ef 1, drop ; forth dev 14336
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 ;
pci q ;
ok show black screen text regs cr devs cr dev @ h. cr 6800 pci h. 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 -7326896

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 + ;

audio ess tech maestro2e ac-97 empty macro
2@ dup a! ed66 2, ;
2! a! ef66 2, drop ;
4@ dup ed 1, ;
4! ef 1, drop ; forth
us 100 * for next ;
nb cf8 a! 4! cfc a! ;
ess! 80006800 + nb 4! ;
on 5 4 ess! 0 c4 ess! ;
wind 1240 40 ess! 9a840058 50 ess! 100 58 ess! 3810 60 ess! ;
r@ 1400 + 2@ ;
r! 1400 + 2! ;
rdy 1430 2@ 1 and drop if 2 us rdy ; then ;
ac@ rdy 80 + 1430 2! 21 us rdy 1432 2@ ;
ac! rdy swap 1432 2! 1430 2! ;
rb@ 1434 a! 4@ ;
rb! 1434 a! 4! ;
ac0 8000000 rb! 2 us 30000000 rb! 21 us ;
ac1 ff6 64 ess! 9 68 ess! 0 60 ess! 2 us 1 60 ess! 1 us 9 60 ess! 500000 us 9 68 ess! 84 us 10000000 rb! ;
try 80 1430 2! 61 us 1430 2@ ;
version 7c ac@ ; on 66 load

audio test x 0
wpa 1402 2! 1400 ;
wp@ wpa 2@ ;
wp! over over wpa 2! over 1400 2@ or drop if wp! ; then drop drop ;
aa 1 wp! 0 ;
apu@ aa wp@ ;
apu! aa wp! ;
wca 1410 2! 1412 ;
wc@ wca 2@ ;
wc! wca 2! ;
h.s h.4 space ;
ac? dup ac@ h.s dup h.s dup 2/ dup wp@ h.s dup apu@ h.s dup wc@ h.s h.s ;
regs x @ 20 + 11 for dup r@ h.s ac? cr -2 + next drop ;
ok show black screen text regs keyboard ;
u 20 x +! ;
d -32 x +! ;
agg0 9240 40 ess! 1000c0 50 ess! 4000 18 r! 10000 us 0 18 r! 500 7 wp! 140 14 r! 1fc 4 for 200000 1000 / over wp! 1 + next drop ac0 ;

editor empty macro forth blk 0 cur 0 prev 0
nul ; 70 load
edit blk !
e ;
ok show black screen keyboard ;
h pad nul nul accept nul nul nul nul nul -w -l +l +w -b nul nul +b nul nul nul nul nul nul nul nul nul nul nul nul 2500 , 0 , 0 , 2b000023 , 0 , 0 , 0 ,

keys
+w 1 cur +! ;
-w prev @ cur ! ;
+l 8 cur +! ;
-l -8 cur +! ;
+b 1 +
*b dup blk ! ;
-b -1 + 24 max *b ;

display
one dup f and jump
list @ 0 or if one list ; then drop ;

spy empty 3f8 54 load init
ry 5 r p@ ; 82 load init
buffer 2000 block ; 2000 1 erase buf 73 0 buf !
b! swap ff and + buf @ buffer + ! 1 buf +! ;
dev r2 if dup xmit 100 b! dev ; then ;
pc ?rcv if dup x2 0 b! pc ; then ;
relay s2 st s2! st! dev pc ;
.1 f and digit ;
.byte dup 10 / .1 .1 ;
traffic text buffer buf @ 1 max 400 min for dup @ green 100 ? if red then .byte 1 + next drop ;
ok show black screen relay traffic keyboard ;
k show black screen relay keyboard ;
q 6000 for relay next ;
test st! st ; 84 load

serial 2
r 2f8 + ;
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! ;
x2 5 r p@ 20 and drop if 0 r p! ; then x2 ;
c2 6 r p@ 30 and 30 or drop if c2 ; then x2 ;
s2 6 r p@ xbits ;
s2! 4 r p! ;
r2 5 r p@ 1 and drop if 0 r p@ ; then ;

dynapulse 200m
send pop swap for dup 1@ x2 1 + next drop ;
reset 2 send 2323 ,
1st 12 send 37269a12 , 39027afd , 23c75680 ,

format floppy empty macro
p@ 0 ec 1, ;
p! ee 1, drop ; forth hd 1
array pop 2/ 2/ ;
com align array 1202004d , 6c 2,
done 3f4 a! p@ d0 or drop if done ; then ;
byte n ready p! ;
sectors nn-n 18 for over byte hd @ byte dup 18 mod 1 + byte 2 byte 1 + next drop ;
head nn-n dup hd ! 400 * 1202004d + com ! seek com 6 command dup 2* - 1801 + sectors done ;
cylinders n 0 swap for 0 head 1 head 1 + next stop drop ;
format 12 cylinders ;

increase speed from 2 cylinders/s to 3
p@ read byte from port in a
p! write byte to port in a
array -a return next word address
com -a address of command string
done wait till last sector formatted. till ready to read
byte n send byte to fdc when ready
sectors nn-n send 4 format bytes to each of 18 sectors. sector number from 1 to 18
head nn-n set head number. issue seek and format commands. starting sector number depends on cylinder, allowing 2 sector times to step heads. cylinder 1: 17 18 1 2 ... 16. 1801 + adjusts for 1s complement and for unsigned mod
cylinders n format both heads of each cylinder, starting at 0
format standard number of cylinders. smaller is faster

hard disk empty macro
2/s ?lit f8c1 2, 1, ;
p@ dup a! ec 1, ;
p!+ 42ee 2, ;
1! 91 1, drop ;
insw 1! 97 1, 6df266 3, 97 1, ;
outsw 1! 96 1, 6ff266 3, 96 1, ; forth
2dup over over ;
bsy 1f7 p@ 80 and drop if bsy ; then ;
rdy -n 1f7 p@ 8 and drop if 1f0 a! 256 ; then rdy ;
sector 1f3 a! swap p!+ 8 2/s p!+ 8 2/s p!+ 8 2/s e0 or p!+ drop p!+ drop 2* 2* ;
read an 20 sector 256 for rdy insw next drop ;
write an bsy 30 sector 256 for rdy outsw next drop ; 92 load

boot: 3f fat0: 5f fat1: 25a5 dir: 2 cl forth: 8e6d cl
reg dup p@ ff and 2 h.n space 3 h.n cr ;
regs 7 for i 1f0 + reg -next ;
ok show blue screen text regs keyboard ;
cl 20 * 4aab + ;
buffer 2000 block ;
?fort dup @ 54524f46 or drop ;
cl0 dup 5 + @ 10000 * swap 6 + @ 16 2/s ffff and or ;
find -n buffer dup 2 cl read 256 for ?fort if 8 + *next drop ; then cl0 pop drop ;
fort 8e6d cl ;
+2 8000 u+ 100 + ;
reads for 2dup read +2 next drop drop ;
writes for 2dup write +2 next drop drop ;
get buffer fort 9 reads ;
cf! 0 fort 2 writes ;

deskjet empty 40 load
nb 768 3 * ; 42 load
pixels for pix next drop drop ;
drow string 33622a1b , 622a1b4d , 5730 2,
rpt drow 10 type drop ;
columns for 264 2 erase dup buffer 8 * 768 pixels line rpt rpt 2 + next drop ;
res 300 2, 300 2, 2 2, ;
esci string 306c261b , 6f2a1b4c , 1b4d312e , 3033742a , 2a1b5230 , 55342d72 , 32672a1b 4025736 res res res res 32722a1b , 53343033 , 30722a1b , 722a1b41 , c4362 3,
print esci 37 type f0000000 767 1024 * 2 * + 1024 columns 6 type drop ;
tx string 3f and if 3f or if ; then c0 or ; then ;
text tx map ! print ;
it table map ! print ;

printer macro
p@ ec 1, ;
p! ee 1, ;
@w 8b66 3, ;
@b 8a 2, ;
+a c2ff 2, ;
bts 10ab0f 3, drop ;
2/s ?lit f8c1 2, 1, ; forth
ready p@ 80 and if ; then ready ;
delay for next ;
emit 378 a! p! +a ready +a 8d or p! 30 delay 1 or p! drop ;
type for dup @b emit 1 + next ;
buffer 264 block 4 * ;
string pop ;
!b dup - 7 and a! dup 3 2/s bts 1 + ;
three !b
two !b
one !b
nul drop ;
white ffff and dup ffff or drop if - then ;

deskjet
-nb nb negate u+ ;
bcmy string 10243800 , 3033 , 200022 , 10000011 , c00f , 4003 , 0 , 0 , 8000a , 0 , 800002 , 0 , 4000005 , 0 , 0 , c0000001 ,
ye nb 3 * u+
all over over 3 and jump nul one two three
ma -nb 2 2/s all ;
cy -nb 2 2/s all ;
bl -nb 2 2/s all ; map 1050918
6b c618 and 3 2/s dup 3 2/s or 3c3 and dup 4 2/s or 3f and ;
table string bcmy + @b ;
ex map @ push ;
pix over @w 6b ex ff and if ye ma cy bl then drop 3 + 1024 -2 * u+ ;
arow string 30622a1b , 4d 1,
trbp string 32622a1b , 563838 3,
trbr string 32622a1b , 573838 3,
color 7 type drop nb 8 / type ;
line arow 5 type drop buffer 3 for trbp color next trbr color drop ;

x18 simulator empty macro
2/s ?lit f8c1 2, 1, ; forth
state 1fff block ; 102 load
reset r 26 for 100000 over ! 1 + next drop 180 mem @ ir ! 181 pc ! 0 slot ! ;
un. 5 for 37 emit next ;
undef 100000 ? if drop un. ; then 5 h.n ;
r. a-a dup @ undef cr 1 + ;
stack sp @ 8 for dup ss r. drop -1 + next drop ;
return rp @ 8 for 1 + dup rs r. drop next drop ;
ok show black screen text green return r r. blue r. r. white r. r. green r. r. drop stack keyboard ; reset ok

2/s n shift right n bits
state -a address of state vector for current computer
reset set registers undefined, execute from rom
un. display undefined register
h.n nn display n hex digits of number
undef n bit 20 set means undefined
r. display register
stack display stack, top at top
return display return stack, top at bottom
ok display registers, b a blue, pc ir white

registers
r state ;
b state 1 + ;
ar state 2 + ;
pc state 3 + ;
ir state 4 + ;
t state 5 + ;
s state 6 + ;
slot state 7 + ;
ss 7 and 8 + state + ;
rs 7 and 16 + state + ;
rp state 24 + ;
sp state 25 + ;
mem 2000 block + ; 106 load 104 load
s1 ir @ 8 2/s inst ;
s2 ir @ 3 2/s inst ;
s3 0 slot ! ir @ 4 and drop if ret then pc @ mem @ ir ! 1 pc +!
s0 ir @ 13 2/s inst ;
step slot @ jump s0 s1 s2 s3
steps for step next ;

name 26 registers in state vector
ar -a a register. cannot be named a because pentium macro takes precedence
s0-s3 execute instruction from slot 0-3
step execute next instruction
steps n execute n instructions

instructions
nul ;
call pc @ +r
jmp ir @ 1ff and pc ! ;
jz t @ dup or
jc drop if 3 slot ! ; then jmp ;
jns t @ 20000 and jc ;
ret -r pc ! ;
@b b @
@x mem @ +t ;
@+ ar @ 1 ar +! @x ;
n pc @ 1 pc +! @x ;
@a ar @ @x ;
!b b @ 1 b +!
!x -t swap mem ! ;
!+ ar @ 1 ar +! !x ;
!a ar @ !x ;
inst n 1 slot +! 1f and jump jmp jmp call call jz jz jns jns @b @+ n @a !b !+ nul !a -x 2*x 2/x +* orx andx nul +x r@ a@ t@ s@ r! a!x nul t!

define action of each instruction
inst n jump vector for 32 instruction codes

instructions
+r n r @ rp @ 1 + dup rp ! rs ! r ! ;
-r -n r @ rp @ dup rs @ r ! -1 + rp ! ;
+t n t @ s @ sp @ 1 + dup sp ! ss ! s ! t ! ;
-t -n t @ s @ t ! sp @ dup ss @ s ! -1 + sp ! ;
-x t @ 3ffff or t ! ;
2*x t @ 2* 3ffff and t ! ;
2/x t @ dup 20000 and 2* or 2/ t ! ;
+* t @ 1 ? if s @ + then 2/ t ! ;
orx -t t @ or t ! ;
andx -t t @ and t ! ;
+x -t t @ + 3ffff and t ! ;
r@ -r +t ;
a@ ar @ +t ;
t@ t @ +t ;
s@ s @ +t ;
r! -t +r ;
a!x -t ar ! ;
t! -t drop ;

+r n push onto return stack
-r -n pop from return stack
+t n push onto data stack
-t -n pop from data stack
-x some instructions named with terminal x to avoid pentium conflict

x18 target compiler empty h 2097547 ip 2097546 slot 3 macro
2*s ?lit e0c1 2, 1, ; forth
memory 2000 block ;
org n memory + dup h ! ip ! 0 slot ! ;
, n h @ ! 1 h +! ;
s3
s0 h @ ip ! 13 2*s , 1 slot ! ;
s1 8 2*s
sn ip @ +! 1 slot +! ;
s2 3 2*s sn ;
i, slot @ jump s0 s1 s2 s3
25x 114 load ; 116 load 110 load 112 load n x18 call class 25x

prototype for target compilers
h address of next available word in target memory
ip address of current instruction word
slot next available instruction slot
2*s n shift left n bits
memory -a host address for target memory
org n set current target memory location
, n compile word into target memory
s0-s3 assemble instruction into slot 0-3
i, assemble instruction into next slot
25x compile code for multicomputer

instructions
nop 1e i, ;
adr n-a slot @ 2 or drop if nop then i, ip @ ;
call defer a 2 adr +! ;
if -a 4 adr ;
-if -a 6 adr ;
then a h @ 1ff and swap +! ;
@+ 8 i, ;
@b 9 i, ;
n defer 8 f@ execute a i, , ;
@ b i, ;
!+ c i, ;
!b d i, ;
! f i, ;
- 10 i, ;
2* 11 i, ;
2/ 12 i, ;
+* 13 i, ;
or 14 i, ;
and 15 i, ;
+ 17 i, ;

words being redefined for the target computer. these pentium words can no longer be executed. although pentium macros still take precedence during compilation, they will no longer be used.
adr n-a assembles instruction, but not in slot 2, where address goes. instruction address left on stack
call deferred to class. executed for target defined words
then a puts address in low 9 bits of previous instruction word
n executed for green short-numbers. all 18-bit target numbers are short. executes white short-number to put interpreted number on stack. then assembles literal instruction with number in next location

instructions
pop 18 i, ;
a 19 i, ;
dup 1a i, ;
over 1b i, ;
push 1c i, ;
a! 1d i, ;
drop 1f i, ;
; 4 ip +! ;

more target instructions
; since it will be executed, it does not conflict with the pentium macro

25x rom 180 org 0 dup - dup - dup - dup - dup - dup - dup - dup - dup push push push push push push push push push a! a nop

target
defer -a pop ;
execute a push ;
class a last 1 + ! ;
f! an sp + ! ;
f@ n-a sp + @ ; ?com 1384 csho 1331
empty empt 0 class csho @ ?com @
functions aa 4 f! 6 f! ;
x18 a 4 f@ ?com ! 6 f@ csho ! 1 f@ functions ;

defer -a byte address of the compiled code that follows
execute a code at this address
class a store address of code to be executed for each word subsequently defined
f! an store address of code executed when a word with this function is interpreted
f@ n-a fetch address of function code
empty redefine empty to restore altered functions
functions aa store functions
x18 save compile and number functions. set green short-number to n, compile to execute. target words are executed to assemble instructions

lite-on c169b macro
align here 7 and 3 or drop if nop align ; then ; forth
array pop 2/ 2/ ;
us n 550 3 / * for next ;
r n-a ffaffe00 + 2/ 2/ ;
rom a-n 600 + 98 r ! 100 us 48 r @ ;
3rom 2 rom 1 rom 0 rom ;
reset 1 0 r ! 1 us 4000000 0 r ! 1000 us ;
frag 80000000 , 1000000 , 0 , here 40000004 + , ;
tx align array frag frag frag 80000000 , c2000000 , 0 , tx 4 * 40000000 + , f 16
n tx 1 + ;
a tx 2 + ;
fr! f @ + ! ;
first an 0 f ! 20000000 or
send an 1000000 or n fr! 40000000 or a fr! 4 f +! ;
last an c3000000 or send -1 8 r ! ;

move sdn move n bytes from source to destination. register 1 is used, 6 and 7 are saved
array -a returns word-aligned address in dictionary
us n delay n microseconds. edit cpu clock rate
r n-a word address of register. edit base address from north pci device configuration
rom a-n fetch 2 bytes of ethernet id
3rom nnn 3 byte-pairs of id. 54, 32 and 10
reset controller
tx -a transmit buffer. 1536 bytes. fragments must be assembled for transmission
rx -b receive buffer. 8k+16 bytes
n -a tx status/length. writing starts transmission
send an fragment into transmit buffer
first an fragment. wait till buffer empty
last an fragment. start transmission
init ialize controller. set tx/rx address/on and perfect match

receive
rx align array 80000000 , 1000600 , 2000 block 4 * 40000000 + dup , here 40000004 + , 80000000 , 1000600 , 600 + , rx 4 * 40000000 + ,
wait -a rx @ 0 or drop -if wait ; then rx 2 + @ 40000000 or 2/ 2/ ;
init reset rx 10000000 + 2 * 2* 18 r ! 1 us tx 10000000 + 2 * 2* 20 r ! 1 us 2000 30 r ! 1 us -1 28 r ! ;
reg dup r @ h. space 2 h.n cr ;
regs b8 reg a0 reg 98 reg 90 reg 78 reg 60 reg 48 10 for dup reg -8 + next drop ;
ok show red screen text regs keyboard ; ok

wait -b till packet received
reg a display register and address
regs display interesting registers
ok diagnostic display

serial macro
p@ a! ?dup ec 1, ;
p! a! ee 1, drop ;
1@ 8a 2, ; forth
r 3f8 + ;
115200 1 ;
b/s 83 3 r p! 115200 0 r p! 0 1 r p! 3 3 r p! ;
init b/s 16550 0 2 r p! b 4 r p! 1 1 r p! ;
xmit n 5 r p@ 20 and drop if 0 r p! ; then xmit ; macro
5@ ?dup c58b 2, ;
5! c589 2, drop ;
5!+ ec 1, 45004588 , ; forth c interrupt
rcv 2push 0 r a! 5!+ clear 2pop i;
receive a 2* 2* 5! init ef 21 p! sti ;
bytes an-a over + negate
wait pause dup 5@ + drop -if wait ; then drop ;
send an for dup 1@ xmit 1 + next drop ;

p@ p-n fetch byte from port
p! np store byte to port
1@ a-n fetch byte from byte address
r n-p convert relative to absolute port
115200 -n baud-rate divisor. name, not number
b/s set baud rate. edit to change
init initialize uart. fifo off, receive interrupt on, dtr rqs on
xmit n wait for ready and transmit byte
5! a load register 5. reserved as byte input pointer
5@ -a fetch it
5!+ n fetch port, store byte, increment pointer
rcv receive interrupt. buffers byte in memory. must not use data stack
receive start input enabling only serial interrupt. keyboard off requires screen, suspend and standby off also
count -n bytes received
send an message

interrupts
idt 200 block ; macro
1ld n ?lit b9 1, , ;
p! na a! ee 1, drop ;
lidt b 18010f 3, drop ;
sti fb 1, ; enable interrupts somewhere
cli fa 1, ; add to empty!
2push 5250 2, ;
2pop 585a 2, ;
forth 2push be5651 3, idt 100 + a, ;
/forth 595e 2, 2pop ;
clear 20e620b0 , ;
8clear a0e620b0 , 20e6 2, ;
i; cf 1, ; forth
!idt a lidt ; here 3b7 2, idt a, !idt
interrupt n 2* idt + here ffff and 80000 + over ! here ffff0000 and 8e00 + swap 1 + ! ;
fill an for dup interrupt 1 + next drop ; 0 70 fill
ignore i; 8 8 fill
ignore 2push clear 2pop i; 70 8 fill
ignore 2push 8clear 2pop i; 0 interrupt
0div 7fffffff 1ld i;

idt -a table of 2-word interrupts. edit convenient block number
1ld n load register 1 with literal
lidt load interrupt table register from byte address on stack
sti enable device interrupts
cli disable them
2push save registers 0 and 2
2pop restore 2 and 0
forth save 1 and 6, load 6 as stack. interrupt may occur while its a source address
/forth restore 6 and 1
clear store 20 to port 20 to clear irq 0-7
8clear also 20 to port a0 to clear irq 8-f
i; return from interrupt - restore flags
!idt b execute lidt
interrupt n construct interrupt to here. avoid yellow-green literal with red comment
fill an n entries in default interrupt table
ignore clear the interrupt. doesnt clear the device
0div make divisor +infinity, quotient 0

realtek rtl8139b macro
move sdn c189 2, drop c78957 3, drop c68956 3, a4f3 2, 5f5e 2, drop ; forth
1us 1
us n 2144 3 / * for next ;
r n-a 5800 14 + pci + 2/ 2/ ;
rom a-n r @ ;
3rom nnn 4 rom 0 rom dup 16 for 2/ next swap ;
tx -b 2000 block 4 * ;
rx -b tx 1536 + ; ds 0 fr 46
n -a ds @ 10 r + ;
send an fr @ tx + swap dup fr +! move ;
first an n @ 2000 and drop if ds dup @ 1 + 3 and swap ! 0 fr ! send ; then first ;
last an send tx ds @ 20 r + ! fr @ 60 max n ! ;
reset 10000000 34 r ! 100 us ;
init rx 30 r ! 1us reset c000000 34 r ! 1us 8a 44 r ! 3 ds ! fb dup 21 p! a1 p! sti
/int ffff0001 3c r ! ;
rcvd -b 38 r @ dup 10000 / 1fff and fffffff0 + 38 r ! 10 + 1fff and rx 4 + + ;