{block 24}
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, , ;

{block 25}
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!

{block 26}
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 ;

{block 27}
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

{block 28}
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 ;

{block 29}
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

{block 30}
colors etc
block 100 * ;
white ffffff color ;
red ff0000 color ;
green ff00 color ;
blue ff color ;
silver bfbfbf color ;
black 0 color ;
magenta ff00ff 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 31}
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

{block 32}
dump x 290946 y 2106432
one dup @ h. space dup h. cr ;
lines for one -1 + next drop ;
dump x !
r show blue 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 h. 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

{block 33}
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

{block 34}
icons macro
@w 8b66 3, ;
!w a! 28966 3, drop ;
*byte c486 2, ; forth ic 70 cu 191
sq xy @ 10000 /mod 16 + swap 16 + box 17 0 +at ;
loc ic @ 16 24 8 */ * 18 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 @ h. keyboard ; 36 load ok h

{block 35}
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

{block 36}
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 , 110160c , 2b000023 , 0 , 0 , 0 ,

{block 37}
edit icon

{block 38}
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 ;

{block 39}

{block 40}
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 ;

{block 41}

{block 42}
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! ;

{block 43}

{block 44}
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 ;

{block 45}
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

{block 46}
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

{block 47}

{block 48}
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 ;

{block 49}

{block 50}
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 ;

{block 51}

{block 52}
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 ;

{block 53}

sr 4210752 4210752 4210752

{block 54}
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 ;

{block 55}
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

{block 56}
hexagon col 14712896 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

{block 57}
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

{block 58}
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 ,

{block 59}
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

{block 60}
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 ;
mtcf
l 170 load ; mark empty

{block 61}

{block 62}
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 + ;

{block 63}

{block 64}
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

{block 65}

{block 66}
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 ;

{block 67}

{block 68}
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 ,

{block 69}

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

{block 71}

{block 72}
editor display macro
@b 8a 2, ; forth
bksp xy @ 12 10000 * negate + xy ! ;
emitw unpack if emit emitw ; then space drop drop ;
ecap unpack if 48 + emit ecap ; then space drop drop ;
nul drop ;
dig pop + @b ff and emit ;
edig dig 1b1a1918 , 1f1e1d1c , 13052120 , e04100a ,
odig dup f and swap 2/ 2/ 2/ 2/ fffffff and ;
hex odig if hex edig ; then drop edig ;
num if c0c000 and color hex space ; then color . ;
ex bksp emitw ;
gw ff00 color emitw ;
cw ffff color emitw ;
yw ffff00 color emitw ;
ww ffffff color emitw ;
ys ffff00
short push dup 2/ 2/ 2/ 2/ 2/ swap 10 and drop pop num ; 74 load

{block 73}

{block 74}
long push 1 u+ 10 and drop dup @ pop num ;
yn ffff00 long ;
gs ff00 short ;
gn ff00 long ;
x xy @ 10000 / ;
rcr x 3 or drop if cr then ;
rw rcr ff0000 color emitw ;
var ff00ff color emitw 0 gn ;
cap ffffff color unpack 48 + emit emitw ;
acap ffffff color ecap ; blknr 174
word dup -16 and swap f and jump ex yw yn rw gw gn gs cw ys ww cap acap var nul nul nul
?ring dup 1 u+
t blknr @ block text
n dup @ -1 ? if word 1 + n ; then drop drop ;
ok show black screen t keyboard ; ok

{block 75}
mandelbrot set dep 24
o 0 0 dep @ 1 max for vndup itr vdup vlen f0000000 + drop -if *next drop drop 0 ; then drop drop pop hue ;
mh x @ swap 1024 for o wf+ inc @ u+ next nip ;
mv y @ 768 for mh inc @ negate + next drop ;
+d 2 dep +!
-d -1 dep +! dep @ 1 max dep !
draw drop 1e80000 frame ! mv dep @ ;
ok show keyboard ;
l inc @ 1023 8 */ negate x +! draw ;
u inc @ 767 8 */ y +! draw ;
d inc @ 767 8 */ negate y +! draw ;
r inc @ 1023 8 */ x

{block 76}
test test test

{block 77}

{block 78}

{block 79}

{block 80}
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

{block 81}

{block 82}
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 ;

{block 83}

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

{block 85}

{block 86}
dnum drop evpac ;
b10 10 base ! evnm1 ;
b16 16 base ! evphx ;
pnum pad nul dnum evpac nul digit digit digit nul digit digit digit digit digit digit digit nul nul nul nul nul nul nul nul nul nul nul nul nul 2515 , 1b1a19 , 181e1d1c , 21201f , 0 , 0 , 0 ,
phex pad nul dnum evpac nul digit digit digit nul digit digit digit digit digit digit digit nul nul digit digit digit nul digit digit digit nul nul nul nul 2515 , 1b1a19 , 181e1d1c , 21201f , a130500 , e041000 , 0 , 148 load

{block 87}

{block 88}
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 ;

{block 89}
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

{block 90}
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

{block 91}

{block 92}
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 ;

{block 93}

{block 94}
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 ;

{block 95}

{block 96}
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 ;

{block 97}

{block 98}
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 ;

{block 99}

{block 100}
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

{block 101}
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

{block 102}
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 ;

{block 103}
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

{block 104}
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!

{block 105}
define action of each instruction
inst n jump vector for 32 instruction codes

{block 106}
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 ;

{block 107}
+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

{block 108}
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

{block 109}
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

{block 110}
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, ;

{block 111}
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

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

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

{block 114}
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

{block 115}

{block 116}
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 ;

{block 117}
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

{block 118}
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 ! ;

{block 119}
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 1rces 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

{block 120}
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

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

{block 122}
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 ;

{block 123}
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

{block 124}
interrupts
a, a, ;
idt 324 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;

{block 125}
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

{block 126}
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 3 fr 42
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 + + ;

{block 127}
move sdn move n bytes from source to destination. register 1 is used, 6 and 7 are saved
us n delay n microseconds. edit cpu clock rate
r n-a word address of register
rom a-n fetch 2 bytes of mac
3rom nnn 3 byte-pairs of mac
tx -a transmit buffer. 1536 bytes. fragments must be assembled for transmission
rx -b receive buffer. 8k + 1532 byte overrun
ds -a must cycle thru 4 tx descriptors
fr -a must accumulate fragments in tx buffer
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
reset controller
init ialize controller. set tx/rx address/on and mac/broadcast. enable irq10
rcvd -b received packet. register 38 is 10 bytes before start of next packet. register 3a is end of current packet

{block 128}
display registers
reg a dup r @ h. space 2 h.n cr ;
regs 48 19 for dup reg -4 + next drop ;
ok show red screen text regs picst keyboard ;

{block 129}
reg a display register and address
regs display interesting registers
ok diagnostic display
48 counter. neat!
44 rx configuration
40 tx configuration
3c interrupt
38 rx count/address
34 command
30 rx 8k ring buffer
2c-20 tx address
1c-10 tx status
c-8 multicast id, unused
4 mac 54
0 mac 3210

{block 130}
ethernet 188 load 46 load t1 57723
empty cli empt logo ; macro
w 66 1, ;
w@ 8b 2, ;
w! w 289 2, drop ;
*byte c486 2, ; 142 load forth 126 load
n@ w w@ ffff and *byte ;
2! a! w! ;
n! a! *byte w! ;
n, *byte 2, ;
string pop ;
packet string -1 dup dup 2, 2, 2, 3rom 2, 2, 2, 0 n,
length n packet 12 + n! ;
3! swap over 2! 2 + swap over 2! 2 + 2! ;
ethernet n length packet 14 first ;
+ethernet -a rcvd 14 + ; 132 load 140 load 136 load 138 load 2a interrupt
serve forth 1 t1 +! receive /int 8clear /forth i; init 1000 us 184 load 128 load ok

{block 131}
empty redefined to disable interrupts
w 16-bit prefix
w@ b-n fetch 16-bits from byte address
w! nb store 16-bits
*byte n-n swap bytes 0 and 1
n@ b-n fetch 16-bit network-ordered number
2! nb store 16-bit number
n! nb store 16-bit number in network order
n, n compile 16-bit number in network order
string -b returns byte address
packet -b ethernet packet header
dest -b destination field in packet
src -b source field
length n store length into packet
3! nnnb store 3-word mac
ethernet n send header with type/length
@ethernet -b return payload address of received packet

{block 132}
arp for a single correspondent
c.
n. . ;
. n 1, ;
message string 1 n, 800 n, 6 . 4 . 1 n,
me 3rom 2, 2, 2, ip 192 . 168 . 3 . 2 .
to 0 0 0 2, 2, 2, ip 192 . 168 . 3 . 1 .
sender 8 + ;
target 18 + ;
dir 6 + ;
ip 6 + w@ ;
ar n message dir n! 806 ethernet message 28 last ;
arp cli -1 dup dup packet 3! 1 ar sti ;
-arp b-b dup -2 + n@ 806 or drop if ; then pop drop
me? dup target ip message sender ip or drop if ; then dup sender packet 6 move
query? dup dir n@ 1 or drop if ; then sender message target 10 move 2 ar ;

{block 133}
set ip addresses with edit. normal order, net bytes first
. n compile byte. resembles url punctuation
message -b 28-byte string
me comment marking my mac/ip address
to comment marking correspondent
sender
target
dir -b fields in either message or received message
ip b-n fetch ip address
ar n send query 1, or reply 4
arp broadcast query
-arp b-b return if not arp. otherwise process and skip out.
me? b return if broadcast not for me. save sender only in packet
query? b if a request, reply

{block 134}
ipv6
header string 1000060 , 0 n, 11 . 64 .
to 0 , 0 , 0 , ip 192 . 168 . 3 . 1 .
me 0 , 0 , 0 , ip 192 . 168 . 3 . 2 .
length n header 4 + n! ;
dest header 20 + ;
src header 36 + ;
ip n 86dd ethernet length header 40 send ;
+ip b-b dup -2 + n@ 86dd or drop if pop ; then 40 + ;

{block 135}
set ip addresses with edit. normal order, net bytes first
header -a 40-byte ipv6 header
length n store 2-byte length in header
dest -a 4-byte destination ip address
src -a source ip
ip n send ip header embedded in ethernet packet
+ip b-b skip out if not ip. otherwise return payload address

{block 136}
udp macro
b! a! 288 2, drop ; forth
b@ b-n w@ ff and ;
header align string 4444 n, 4444 n, 8 n, 0 n, 0 n,
length n 8 + header 4 + n! ;
udp n dup 8 + ip length ; proto 17
setdp dup n@ header 2 + n! ; set udpdestport
udport n header n! ; set udpsourceport
+udp b-b dup -11 + b@ dup proto ! 11 or drop if pop ; then setdp 8 + ;

{block 137}
b@ b-n fetch byte
header -a 8-byte udp header
length n store length in header
udp n send ip header for n-byte packet
+udp b-b skip out if not udp. otherwise return payload address

{block 138}
blocks to/from server
payload n-bn header 8 + n! header 10 ;
udppay payload -2 + ; standard minimal udp header length
+put nn 4444 udport 1026 udp over payload send + block 2* 2* 1024 last ;
it b dup 2 + swap n@ 32768 + block 2* 2* 1024 move ;
-got b-b dup -4 + n@ 2 8 + or drop if it pop ; then ; ep 8390162 el 208
snif dup dup ep ! 2 + n@ el ! ; 160 load
receive +ethernet snif -arp +ip +udp -tftp -got
+get b n@ 32768 +put ;
... interrupt-protect words that transmit
get n 65535 min cli 4444 udport 2 udp payload last sti ;
put n cli 0 +put sti ;
archive 161 for i put 1000 us -next ;
@el el @ 518 min ;
cnt @el h. cr cr ;
dmp cnt white @el 2 / for dup @el 2 / i negate + 2 * + n@ .hw space next drop ;
okd show blue screen text ep @ dup red h. space dmp keyboard ;

{block 139}
client can get or put blocks to server
payload n-bn 2 bytes were appended to udp header for block number
+put nn send block number. append block as last fragment. packet length distinguishes two messages
it b move 1024 bytes from packet to offset block
-got b-b if a 2-byte message, return. otherwise move block to archive - 300+ - and skip out
receive check and decode received packet. +test returns if true, -test returns if false. otherwise they pop - skip-out - return from receive. resulting stack need not be empty, since /forth will restore pre-interrupt stack. pop must be in a word called by receive, it cant be nested
+get b send requested block from archive
get n send block number to request. interrupt disabled lest reply interfer
put n send block
archive send blocks 0-161 - 9 cylinders

{block 140}
ipv4
header align string 4500 n, 0 n, 1 n, 0 n, ff11 n, 0 n,
me 192 . 168 . 3 . 2 .
to 217 . 149 . 199 . 177 .
length n header 2 + n! ;
+id header 4 + dup n@ 1 + swap n! ;
0csum 0 header 10 + n! ;
msum dup ffff and swap 10000 / + ffff swap negate + ;
checksum 0csum 0 9 for i 2 * header + n@ + -next msum header 10 + n! ;
source header 12 + ;
destination header 16 + ;
setd dup -8 + dup n@ destination n! 2 + n@ destination 2 + n! ;
ip n 20 + 800 ethernet length +id checksum header 20 send ;
+ip b-b dup -2 + n@ 800 or drop if pop ; then 20 + setd ;
oks show blue screen text destination dup n@ h. 2 + n@ h. keyboard ;

{block 141}

{block 142}
network hex print code macro
1@ 8a 2, ;
1! a! 288 2, drop ; forth
addr pop ;
jht addr 1b1a1918 , 1f1e1d1c , 43352120 , 3e34403a ,
hb jht + 1@ ff and ;
.hw n dup dup dup 1000 / hb emit fff and 100 / hb emit ff and 10 / hb emit f and hb emit ;
htp show red screen text f for i hb emit space -next cr 1234 .hw keyboard ;
fb 1 + block 4 * 1024 for dup i negate + i swap 1! next drop ;

{block 143}

{block 144}

{block 145}

{block 146}

{block 147}

{block 148}

{block 149}

{block 150}

{block 151}

{block 152}

{block 153}

{block 154}

{block 155}

{block 156}
ekbd byte 15 1, 1 1, 13 1, 45 1, 12 1, 22 1, 16 1, 1 1, 35 1, 9 1, 10 1, 43 1, 0 1, 56 1, 58 1, 2 1, 0 , 0 ,
ekb0 byte 21 1, 37 1, 7 1, 0 1,

{block 157}

{block 158}
pad in cf source vector 1470336 ev 0 macro
1@ 8a 2, ;
cedx ff 1, d2 1, ;
wedx c201 2, 582548d , fc5203 3, ad 1, cedx ; forth
g4byt n- 0 ev ! 3 for dup i + 1@ ff and ev @ 256 * + ev ! -next drop ;
pad pop dup vector ! 28 5 * + dup board ! 4 4 * negate + board 1 + !
pa1 cmkey vector @ a! wedx pa1 ;
tcmk 6 for cmkey next ;

{block 159}

{block 160}
tftpd dblk 4 cblks 0 anfc 4 bnfc 5 offset 0 lbs 32771 inb 4
nul ; tmp 4
sd n 32768 + block dump ;
ed n 32768 + edit ;
et 160 edit ;
esb 32768 65535 erase ;
fb nb 512 for over over 512 i negate + 2* + n! next drop drop ;
fsb esb 65535 for 65535 i negate + dup 32768 + block 2* 2* fb next ;
optack align string 6 n, 626c n, 6b73 n, 697a n, 6500 n, 3130 n, 3234 n, 0 .
tack align string 4 n, 0 n,
dpak align string 3 n, 0 n,
1+ack tack 2 + dup n@ 1 + swap n! ;
ascdec 0 tmp ! 1 4 for over i + b@ -48 + over * tmp +! 10 * -next drop ;
destb dup 2 + ascdec tmp @ dup dblk ! offset ! ;
bcount dup 6 + ascdec tmp @ dup cblks ! inb ! ; 162 load

{block 161}

{block 162}
tftpd
uous udp over udppay send ;
sopta cli 69 udport 15 uous optack 15 last sti ;
rdrq destb bcount sopta ;
mvit bnfc @ offset @ + 32767 + block 2* 2* 1024 move 1 dblk +! ;
?mvit cblks @ bnfc @ negate + drop -if ; then mvit ;
sack cli dup 2 + n@ bnfc ! dup 4 + ?mvit 69 udport tack 4 uous tack 4 last 1+ack sti ;
wrrq destb bcount 1 tack 2 + n! sopta sack ;
sbk n cli dup lbs ! offset @ + 69 udport 1028 uous dpak 4 send block 2* 2* 1024 last sti ;
scblk inb @ anfc @ negate + cblks ! ;
sclose cli 4 uous dpak 4 send 0 0 last sti ;
ndblk dup 2 + n@ anfc ! scblk cblks @ 0 or drop if anfc @ 1 + dup dpak 2 + n! dup dblk ! 32767 + sbk ; then dblk @ dpak 2 + n! sclose ;
jack n 6 min jump nul rdrq wrrq sack ndblk nul nul
tftp dup n@ jack ;
-tftp dup -6 + n@ 69 or drop if ; then pop drop tftp ;
. n. ; redefine . to print tos

{block 163}

{block 164}
cell pop 4 / ; here
data align cell 100 , 200 , 300 , 400 , 500 ,
get n- data + @ ;
put nn- 4 min data + ! ;
display 4 for i get . cr -next ;
sum 0 4 for i get + -next cr . ;
line 10 for 35 emit next ;
wipe 4 for 0 i put -next ;
ok show black screen text display line sum keyboard ;

{block 165}

{block 166}
macro
1@ 8a 2, ; forth
byte pop ;
data byte 68 1, 4 1, 12 1, 12 1, 3 1, 0 1, 15 1, 3 1, 1 1, 12 1, 16 1, 42 1,
get n- data + 1@ ff and ;
display 12 dup for dup i negate + get emit -next drop ;
ok show black screen text display keyboard ;

{block 167}

{block 168}
tv 5
t! n- tv ! ;
.tv 50 emit 65 emit space tv @ . ;
d tv @ 72 + emit ;
la 53 emit ;
lb 67 emit ;
lc 58 emit ;
ld 64 emit ;
le 52 emit ;
lf 62 emit ;
oor 0 emit ;
decide tv @ 10 min jump d d d d d d d d d d la lb lc ld le lf oor
ok show red screen text .tv decide keyboard ;

{block 169}

{block 170}
main load screen tnr 0 0 tnr ! vc 0 0 vc ! maxvc 5 5 maxvc ! vckey 1202489 logov 1201941 vector 1159434 ev 0 lkey 2 172 load
rekey vkey 4 * 11 hcka + vkey ! ; 130 load 178 load 174 load
kbdget n-k kbd + 1@ ff and ;
kst 0 64 kbp@ ;
gkey vc @ tnr @ or drop if drop 0 ; then drop 0 60 kbp@ ;
key 0 0 or
k1 ?ref kst 1 and 1 or drop if k1 ; then gkey ;
?chvc dup 7f and negate dup 64 + drop -if drop ; then 58 + -if abs -1 + vc ! ; then drop ;
mkey key ?chvc 15 max 58 min dup -58 + drop if -15 + kbdget dup lkey ! ; then drop mkey ; here vckey !
mtkey mkey ;
g4byt n- 0 ev ! 3 for dup i + 1@ ff and ev @ 256 * + ev ! -next drop ;
pad pop dup vector ! 28 5 * + dup board ! 4 4 * negate + board 1 + !
pa1 mkey vector @ a! wedx pa1 ;
tm 6 for mkey next ;
tc 6 for cmkey next ; vckey @ vkey ! sti

{block 171}

{block 172}
keyboard driver data macro
1@ 8a 2, ;
cedx ff 1, d2 1, ;
wedx c201 2, 582548d , fc5203 3, ad 1, cedx ;
kbp@ ?lit e4 1, 1, ;
@esi 56 1, pop ; forth
byte pop ;
kbd byte 0 1, 16 1, 17 1, 18 1, 19 1, 0 1, 0 1, 4 1, 5 1, 6 1, 7 1, 0 1, 0 1, 0 1, 0 1, 20 1, 21 1, 22 1, 23 1, 0 1, 0 1, 8 1, 9 1, 10 1, 11 1, 0 1, 0 1, 0 1, 0 1, 24 1, 25 1, 26 1, 27 1, 0 1, 1 1, 12 1, 13 1, 14 1, 15 1, 0 1, 0 1, 3 1, 2 1,

{block 173}

{block 174}
video frame buffer refresh
gfb -n fr @ 2/ 2/ ;
gvid -n fr 1 + @ 2/ 2/ ;
refresh gvid gfb 1024 768 * 2 / 1 + for over over i + @ swap i + ! -next drop drop ;
sw 56 1, 358b 2, 330c , 57 1, 3d8b 2, 3310 , b9 1, 60000 , a5f3 2, 5f 1, 5e 1, c3 1,
?ref vc @ tnr @ or drop if yield ; then keyb keyb sw ;
screen
bscr 0 0 at 1024 600 box white ;
show pop dtv vc @ + ! ; here logov ! idtv
mlogo show black bscr 800 600 blue box 600 50 at 1024 600 red box 200 100 at 700 500 green box text cf keyboard ;
sht show red bscr text 1 emit keyboard ;
sht2 show blue bscr text 0 a! 10 for a 1 + a! a h. cr next keyboard ;

{block 175}

{block 176}
keyboard display data macro
1@ 8a 2, ; forth
byte pop ;
alpha byte c010a0d , 8060214 , 110f0913 , 70e0b12 , 16040305 , 10152417 ,
graph byte 1b1a19 , 181e1d1c , 2f21201f , 2c2a2829 , 2e252226 , 232b272d ,
numbrs byte 1b1a19 , 181e1d1c , 21201f , 0 , 0 , 0 ,
octals byte 1b1a19 , 181e1d1c , 21201f , a130500 , e041000 , 0 ,
grap0 byte 50000 ,
grap1 byte 52515 ,
alph0 byte 2d21 ,
alph1 byte 2d2515 ,
numb0 byte e0523 ,
numb1 byte 2515 ,

{block 177}

{block 178}
keyboard screen display 176 load 156 load
getc n-c 1@ ff and ;
four n-n+4 4 for dup getc emit 1 + next ;
eight n-n+8 12 + four space -16 + four ;
3rows n- 3 for eight cr next drop ;
.brd board 9 for dup @ h. space 1 + next drop ;
.hist 353e hcka 11 for dup getc emit 1 + next drop ;
vstkn vc @ dstn ;
vstk0 9f44c hcka ;
jstck vc @ 1 min jump vstk0 vstkn
.stck 0 740 at @esi negate jstck + 4 / -1 + if for @esi 4 / -1 + i + @ n. next ; then drop ;
kpd vector @ 28 5 * + 4 + ;
kpdt vector @ 28 5 * + ;
jbrd board @ -14139 hcka + 24 / 0 max 4 min jump alpha graph numbrs octals kpd
jtk board 1 + @ -14344 hcka + 20 / 0 max 6 min jump grap0 grap1 alph0 alph1 numb0 numb1 kpdt
tkeys jtk four drop ;
keyc board 4 + @ color ;
keyboard ;
keyb 0 600 at 1024 768 blue box 0 603 at keyc .brd cr jbrd 3rows 50 700 at tkeys 125 625 at magenta 65 emit 58 emit space vc @ n. space .hist .stck ;

{block 179}

{block 180}
wami 1200190 t0 460972296 nrtsks 6 6 nrtsks ! nyip 1 1 nyip !
cell pop 2/ 2/ ;
allot n- for 0 , next ;
dtv align cell maxvc @ 1 + allot
tski align cell 11 allot
orsts align cell nrtsks @ allot
ovects align cell nrtsks @ allot
ofbs align cell maxvc @ 1 + allot
ofos align cell maxvc @ 1 + allot
obrds align cell maxvc @ 1 + 9 * allot
kf@ -n fr @ ;
kf! n fr ! ;
kfn n-n 1 + 1024 768 * 2 * * negate 2000000 + ;
skfn n kfn kf! ;
svfb kf@ ofbs vc @ + ! ;
refb ofbs vc @ + @ kf! ;
kfo@ -n fo @ ;
kfo! n fo ! ;
svfo kfo@ ofos tnr @ + ! ;
refo ofos tnr @ + @ kfo! ;
svvec vector @ ovects tnr @ + ! ;
revec ovects tnr @ + @ vector ! ;
svbrd n- 9 * obrds + 9 for dup board 9 i negate + + @ swap ! 1 + next drop ;
ibrd maxvc @ for i svbrd -next ; ibrd
rebrd n- 9 * obrds + 9 for dup @ board 9 i negate + + ! 1 + next drop ;
idtv maxvc @ for logov @ dtv i + ! -next ;

{block 181}

{block 182}
inctnr 1 tnr +! ;
ztnr 0 tnr ! ;
nxttnr nrtsks @ tnr @ negate + 1 min jump ztnr inctnr
rstn n-n 2 * 301 + block 2* 2* ;
dstn n-n 2 * 1 + 301 + block 2* 2* ; macro
puall 60 1, ;
poall 61 1, ;
svrst -n ?dup c48b 2, ;
cs@ -n e 1, pop ;
ef@ -n 9c 1, pop ;
srstn n e08b 2, drop ;
sdstn n f08b 2, drop ;
int20 cd 1, 20 1, ; forth
yield 0 nyip ! int20 ;
neg+ negate + ;
mtski n dup rstn 4 / 11 for 11 i neg+ tski + @ over 11 i neg+ neg+ ! next drop ;
sef ef@ 37002 and tski ! ;
scs cs@ tski 1 + ! ;
sip wami @ tski 2 + ! ;
srt n dup rstn 12 + tski 7 + ! ;
sdt n dup dstn tski 9 + ! ;
sorst n dup rstn -40 + over orsts + ! ;
itsk n sef scs sip srt sdt mtski sorst drop ;

{block 183}

{block 184}
timer interrupt
mt
empty only works from vc0 cli rekey empt logo ;
cli cli ;
sti sti ; macro
picp@ 0 ec 1, ;
tp!
picp! ee 1, drop ; forth
!pit nn 43 a! 34 tp! 40 a! tp! tp! ; 0 0 !pit
0pic1! 20 a! tp! ;
0pic2! a0 a! tp! ;
pic1! 21 a! tp! ;
pic2! a1 a! tp! ;
!pic cli init 11 dup 20 a! tp! a0 a! tp! irq 20 pic1! 28 pic2! master 4 pic1! slave 2 pic2! 8086 mode 1 dup pic1! pic2! mask irqs fb pic2! ed fb pic1! ; !pic
picst white 700 575 at 21 a! picp@ h. space a1 a! picp@ h. 700 600 at a 0pic1! 20 a! picp@ h. space a 0pic2! a0 a! picp@ h. 700 625 at b 0pic1! 20 a! picp@ h. space b 0pic2! a0 a! picp@ h. ; 20 interrupt
timer0 forth svrst orsts tnr @ + ! svfb svfo tnr @ svbrd svvec nyip @ t0 +! 1 nyip ! nxttnr revec tnr @ rebrd refo refb orsts tnr @ + @ srstn clear /forth i;
uma 0 dup pic1! pic2! ;
ma ff dup pic1! pic2! ; 186 load vcs uma

{block 185}

{block 186}
vcs init screen forth 196 load 198 load
vc@ -n vc @ ;
vc! n vc ! ;
at? xy @ 10000 /mod swap ;
vcs show vc@ skfn at? 0 660 at 1024 768 blue box keyboard at ;
n vc @ 1 + maxvc @ min vc ! ;
p vc @ -1 + 0 max vc ! ;
exec a- push ; here wami ! 1 itsk
vc1 sti 1 skfn accept vc1 ; here wami ! 2 itsk
vc2 sti 2 skfn accept vc2 ; here wami ! 3 itsk
vc3 sti 3 skfn accept vc3 ; here wami ! 4 itsk
vc4 sti 4 skfn accept vc4 ; here wami ! 5 itsk
vc5 sti 5 skfn accept vc5 ; here wami ! 6 itsk
dt sti vc @ skfn at? dtv vc @ + @ exec at yield dt ;
dd n 2 * 1 + 301 + block dump ;
dr n 2 * 301 + block dump ;

{block 187}

{block 188}
interrupts
a, a, ;
idt 324 block ; 180 load 182 load 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 puall be 1, idt 100 + a, ;
/forth poall ;
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; 20 8 fill
ignore 2push clear 2pop i; 28 8 fill
ignore 2push 8clear 2pop i; 0 interrupt
0div 7fffffff 1ld i;

{block 189}

{block 190}
serial 3f8 2e8 altered for interrupt useage macro
serp@ a! dup ec 1, ;
serp! a! ee 1, drop ;
1@ 8a 2, ;
1! a! 288 2, drop ; forth
r 0 + + ;
110 1047 ;
300 384 ;
2400 48 ;
9600 12 ;
115200 1 ;
b/s 83 3 r serp! 115200 0 r serp! 3 3 r serp! ;
init 1 1 r serp! 8 4 r serp! b/s 16550 1 2 r serp! 2 2 r serp! c1 2 r serp! ;
xmit n 5 r serp@ 20 and drop if 0 r serp! ; then pause xmit ;
cts 6 r serp@ 30 and 30 or drop if cts ; then xmit ;
st 6 r serp@
xbits 30 and 10 / dup 1 and 2* 2* + 2/ ;
st! 4 r serp! ;
?rcv 5 r serp@ 1 and drop if 0 r serp@ then ;
rcv ?rcv if ; then rcv ;

{block 191}

{block 192}
keyboard scan codes data
addr pop ;
sc-ii addr 32311b00 , 36353433 , 30393837 , 9083d2d , 72657771 , 69757974 , 5d5b706f , 7361000d , 68676664 , 3b6c6b6a , 5c006027 , 7663787a , 2c6d6e62 , 2a2f2e , 20202020 ,
ssc-ii addr 40211b00 , 5e252423 , 29282a26 , 82b5f , 52455751 , 49555954 , 7d7b504f , 5341000d , 48474644 , 3a4c4b4a , 7c007e22 , 5643585a , 3c4d4e42 , 3f3e ,
csi-ii addr 1b00 , 1e000000 , 0 , 7f001f , 12051711 , 9151914 , 1d1b100f , 1301000a , 8070604 , c0b0a , 1c000000 , 1603181a , d0e02 ,
si sc-ii + 1@ ff and ;
ssi ssc-ii + 1@ ff and ;
csi csi-ii + 1@ ff and ;

{block 193}

{block 194}
keyboard driver shft 0 eflag 1 192 load 3f8 190 load init macro
ior 60b binary ;
kbp@ ?lit e4 1, 1, ; forth
nul ;
kst 0 64 kbp@ ;
!shft shft ! ;
@shft shft @ ;
sshft @shft 1 ior !shft ;
rshft @shft fffffffe and !shft ;
sctrl @shft 2 ior !shft ;
rctrl @shft fffffffd and !shft ;
?shft dup dup 7f and ffffffd6 + drop if drop ; then 80 and drop if rshft ; then sshft 80 or ;
?ctrl dup dup 7f and ffffffe3 + drop if drop ; then 80 and drop if rctrl ; then sctrl 80 or ;
?chvc dup 7f and negate dup 64 + drop -if drop ; then 58 + -if abs -1 + vc! ; then drop ;
key kst 1 and 1 or drop if key ; then 0 60 kbp@ ;
seflag 1 eflag ! ;
?seflag @shft 3 or drop if ; then seflag ;
sendk @shft jump si ssi csi nul ;
mkey key ?seflag ?shft ?ctrl ?chvc dup 80 and drop if drop ; then sendk 0 r serp! ; 21 interrupt
ikey forth vc @ ffffffff and drop if mkey then clear /forth i;

{block 195}

{block 196}
added macros macro
0if 75 2, here ; forth ywts

{block 197}

{block 198}
rtc macro
p@ ec 1, ;
p! ee 1, drop ; forth
rtca 70 a! p! 71 a! ;
rtc@ rtca 0 p@ ;
rtc! rtca p! ;
hi 10 rtc@ 80 and drop 0if hi ; then ;
lo 10 rtc@ 80 and drop if lo ; then ;
bcd rtc@ 16 /mod 10 * + ;
hms lo 4 bcd 100 * 2 bcd + 100 * 0 bcd + ;
ymd lo 9 bcd 100 * 8 bcd + 100 * 7 bcd + ;
day lo 6 rtc@ -1 + ;
cal hi lo time - hi lo time + ;

{block 199}

{block 200}

{block 201}

{block 202}

{block 203}

{block 204}

{block 205}

{block 206}

{block 207}

{block 208}

{block 209}

{block 210}

{block 211}

{block 212}

{block 213}

{block 214}

{block 215}

{block 216}

{block 217}

{block 218}

{block 219}

{block 220}

{block 221}

{block 222}

{block 223}

{block 224}

{block 225}

{block 226}

{block 227}

{block 228}

{block 229}

{block 230}

{block 231}

{block 232}

{block 233}

{block 234}

{block 235}

{block 236}

{block 237}

{block 238}

{block 239}

{block 240}

{block 241}

{block 242}

{block 243}

{block 244}
accept vpacc 1159429 vphx 1159044 vnm1 1158871 base 10 10 base ! sign 1
nul ;
pack 0 0 at 28 28 black box text lkey @ . ;
evpac vpacc @ exec ;
evphx vphx @ exec ;
evnm1 vnm1 @ exec ;
racc ffff00 board 4 + ! accept ;
ok show nul keyboard ; 246 load
pgraf pad nul nul nul evpac pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack 500 , 1b1a19 , 181e1d1c , 2f21201f , 2c2a2829 , 2e252226 , 232b272d , here vpacc !
pacc pad nul racc basep pgraf pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack pack 2d2115 , c010a0d , 8060214 , 110f0913 , 70e0b12 , 16040305 , 10152417 ,
macc ff00ff board 4 + ! ok pacc ;

{block 245}

{block 246}
anum byte 0 , 30201 , 60504 , 90807 , c0b0a00 , f0e0d00 ,
gnum lkey @ anum + 1@ ff and ;
?neg sign @ 0 + drop if negate ; then ;
digit base @ * gnum ?neg + ;
dnum drop evpac ;
b10 10 base ! evnm1 ;
b16 16 base ! evphx ;
pnum pad nul dnum evpac nul digit digit digit nul digit digit digit digit digit digit digit nul nul nul nul nul nul nul nul nul nul nul nul nul 2515 , 1b1a19 , 181e1d1c , 21201f , 0 , 0 , 0 ,
phex pad nul dnum evpac nul digit digit digit nul digit digit digit digit digit digit digit nul nul digit digit digit nul digit digit digit nul nul nul nul 2515 , 1b1a19 , 181e1d1c , 21201f , a130500 , e041000 , 0 , 248 load

{block 247}

{block 248}
dig1 gnum ?neg pnum ;
hex1 gnum ?neg phex ;
sneg 1 sign ! 0 base @ -10 + drop if phex ; then pnum ; here vnm1 !
pnm1 pad nul sneg evpac b16 dig1 dig1 dig1 nul dig1 dig1 dig1 dig1 dig1 dig1 dig1 nul nul nul nul nul nul nul nul nul nul nul nul nul e0523 , 1b1a19 , 181e1d1c , 21201f , 0 , 0 , 0 , here vphx !
phx1 pad nul sneg evpac b10 hex1 hex1 hex1 nul hex1 hex1 hex1 hex1 hex1 hex1 hex1 nul nul hex1 hex1 hex1 nul hex1 hex1 hex1 nul nul nul nul 210523 , 1b1a19 , 181e1d1c , 21201f , a130500 , e041000 , 0 ,
basep 0 sign ! base @ -10 + drop if phx1 ; then pnm1 ;

{block 249}

{block 250}
accept version 2 empty 254 load
nul ;
pack black screen text lkey @ . ;
exit logo accept ;
gnum lkey @ anum + 1@ ff and ;
?neg sign @ 0 + drop if negate ; then ;
dig base @ * gnum ?neg + base @ -10 + drop if hex1 ; then num1 ;
jtopk shift @ 0 max 5 min jump pack pack pack pack dig dig
cbase 0 sign ! base @ -10 + drop 0 if hex0 ; then num0 ;
sneg 1 sign ! base @ -10 + drop if hex1 ; then num1 ;
baset base @ -10 + drop if 10 base ! num0 ; then 16 base ! hex0 ;
dnum drop alp0 ;
jth0 shift @ 0 max 5 min jump nul alp0 exit nul sneg dnum
jth1 shift @ 0 max 5 min jump nul alp0 cbase alp0 dnum alp0
jth2 shift @ 0 max 5 min jump alp0 nul grf0 nul baset nul
jk n- 0 max 4 min jump nul jth0 jth1 jth2 jtopk
acc cmkey dup lkey ! jk acc ;
ok show keyb keyboard ; ok acc

{block 251}

{block 252}
keyboard display data macro
1@ 8a 2, ; forth lkey 1 brd 0 0 brd ! shift 2 2 shift ! base 10 10 base ! kcolr 16711935 ff00ff kcolr ! sign 0
byte pop ;
alpha byte c010a0d , 8060214 , 110f0913 , 70e0b12 , 16040305 , 10152417 ,
graph byte 1b1a19 , 181e1d1c , 2f21201f , 2c2a2829 , 2e252226 , 232b272d ,
numbrs byte 1b1a19 , 181e1d1c , 21201f , 0 , 0 , 0 ,
octals byte 1b1a19 , 181e1d1c , 21201f , a130500 , e041000 , 0 ,
grap0 byte 50000 ,
grap1 byte 52515 ,
alph0 byte 2d2115 ,
alph1 byte 2d2515 ,
numb0 byte e0523 ,
numb1 byte 2515 ,
anum byte 0 , 30201 , 60504 , 90807 , c0b0a00 , f0e0d00 ,
sb! shift ! brd ! ;
grf0 1 0 sb! ;
grf1 1 1 sb! ;
alp0 0 2 sb! ;
alp1 0 3 sb! ;
num0 0 sign ! 2 4 sb! ;
num1 2 5 sb! ;
hex0 0 sign ! 3 4 sb! ;
hex1 3 5 sb! ;

{block 253}

{block 254}
keyboard screen display 252 load
getc n-c 1@ ff and ;
four n-n+4 4 for dup getc emit 1 + next ;
eight n-n+8 12 + four space -16 + four ;
3rows n- 3 for eight cr next drop ;
jbrd brd @ 0 max 3 min jump alpha graph numbrs octals
jtk shift @ 0 max 5 min jump grap0 grap1 alph0 alph1 numb0 numb1
tkeys jtk four drop ;
keyc kcolr @ color ;
keyb 0 600 at 1024 768 blue box 3 603 at keyc jbrd 3rows 50 700 at tkeys ;

{block 255}

{block 256}

{block 257}

{block 258}

{block 259}

{block 260}
accept version 3 empty adnul 1191342 here adnul !
nul ;
4nuls 4 for adnul @ , next ;
cell pop 2/ 2/ ;
brda cell 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
brd@ brda @ ;
brd! brda ! ;
shft@ brda 1 + @ ;
shft! brda 1 + ! ;
kcl@ brda 4 + @ ;
kcl! brda 4 + ! ; ff00ff kcl!
base@ brda 2 + @ ;
base! brda 2 + ! ; 10 base!
setv nn- 4 * + 4 / here swap ! ; 264 load
exec push ; alph0 1 setv
exit logo accept ; alph0 4 setv grap0 4 setv
pack black screen text lkey @ . ; 266 load

{block 261}

{block 262}
keyboard display data macro
1@ 8a 2, ; forth lkey 1 sign 0
byte pop ;
alpha byte c010a0d , 8060214 , 110f0913 , 70e0b12 , 16040305 , 10152417 ,
graph byte 1b1a19 , 181e1d1c , 2f21201f , 2c2a2829 , 2e252226 , 232b272d ,
numbrs byte 1b1a19 , 181e1d1c , 21201f , 0 , 0 , 0 ,
octals byte 1b1a19 , 181e1d1c , 21201f , a130500 , e041000 , 0 ,
grap0 align byte 50000 , 4nuls
grap1 align byte 52515 , 4nuls
alph0 align byte 2d2115 , 4nuls
alph1 align byte 2d2515 , 4nuls
numb0 align byte e0523 , 4nuls
numb1 align byte 2515 , 4nuls
anum byte 0 , 30201 , 60504 , 90807 , c0b0a00 , f0e0d00 , alph0 3 setv
grf0 graph brd! grap0 shft! ;
grf1 graph brd! grap1 shft! ; numb1 2 setv grap0 3 setv
alp0 alpha brd! alph0 shft! ;
alp1 alpha brd! alph1 shft! ;
num0 0 sign ! numbrs brd! numb0 shft! ;
num1 numbrs brd! numb1 shft! ;
hex0 0 sign ! octals brd! numb0 shft! ;
hex1 octals brd! numb1 shft! ;

{block 263}

{block 264}
keyboard screen display 262 load
getc n-c 1@ ff and ;
four n-n+4 4 for dup getc emit 1 + next ;
eight n-n+8 12 + four space -16 + four ;
3rows n- 3 for eight cr next drop ;
tkeys shft@ four drop ;
keyc kcl@ color ;
keyb 0 600 at 1024 768 blue box 3 603 at keyc brd@ 3rows 50 700 at tkeys ;

{block 265}

{block 266}
numbers
gnum lkey @ anum + 1@ ff and ;
?neg sign @ 0 + drop if negate ; then ; numb0 4 setv numb1 4 setv
dig base@ * gnum ?neg + base@ -10 + drop if hex1 ; then num1 ; alph0 2 setv
cbase 0 sign ! base@ -10 + drop 0 if hex0 ; then num0 ; numb0 1 setv
sneg 1 sign ! base@ -10 + drop if hex1 ; then num1 ; numb0 3 setv
baset base@ -10 + drop if 10 base! num0 ; then 16 base! hex0 ; numb0 2 setv numb1 1 setv
dnum drop alp0 ;
thumk n- lkey @ 4 min 4 * shft@ + 4 / @ exec ;
jk n- 0 max 1 min jump nul thumk
iacc alp0
acc cmkey dup lkey ! jk acc ;
ok show keyb keyboard ; ok iacc

{block 267}

{block 268}

{block 269}

{block 270}

{block 271}

{block 272}

{block 273}

{block 274}

{block 275}

{block 276}

{block 277}

{block 278}

{block 279}

{block 280}

{block 281}

{block 282}

{block 283}

{block 284}

{block 285}

{block 286}

{block 287}

{block 288}

{block 289}

{block 290}

{block 291}

{block 292}

{block 293}

{block 294}

{block 295}

{block 296}

{block 297}

{block 298}
test

{block 299}

{block 300}

{block 301}

{block 302}
aro; 14139 rtotf 14139 ew? 0 ewid rtoen 0 1202322 rtamd 14306

{block 303}
rte,s

{block 304}
rtotf 14139 eb@ 0 ev; rtoen 0 1202322 rtamd 14306

{block 305}
rte?

{block 306}
rtotf 14139 eq@ 0 ex; rtoen 0 16 1258ec 14530

{block 307}
0

{block 308}
aro; 14139 rtotf 14139 e3@ 0 e1; rtoen 0 1202322 rtamd 14306

{block 309}
rta r

{block 310}
aro; 14139 rtotf 14139 e7@ 0 e5; rtoen 0 16 1258ec 14530

{block 311}
rta o

{block 312}
aro; 332796 aro; 32037314 rryse rrlo aro; 332796 rzn?e rrgse 36236 rtotf 33005968 ek e9@ 20 rtoen 0 16

{block 313}
rta i o
20 t8 n 0

{block 314}

{block 315}

{block 316}

{block 317}

{block 318}

{block 319}

{block 320}

{block 321}

{block 322}