{block 18}
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
77024
y
2100272
one
600
0
+at
dup
@
h.
space
dup
h.
cr
;
lines
for
one
-1
+
next
drop
;
dump
x
!
r
show
cli
black
screen
x
@
31
+
32
text
lines
keyboard
sti
;
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
32
+xy
dup
x
+!
y
+!
;
d
-32
+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
3
cu
101
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
;
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
empt
col
4227200
del
4210752
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
+
;
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
debug
type
dump
80
load
macro
bswap
c80f
2,
;
forth
x
17984
4al
a-
4
for
dup
@b
7f
and
dup
-32
+
drop
-if
drop
2e
then
chc
emit
1+
next
drop
;
8alpha
4
*
dup
4al
35
emit
4
+
4al
;
two
a-
dup
@
bswap
h.
35
emit
1+
@
bswap
h.
;
one
a-a
dup
4
*
7
h.n
46
emit
dup
256
/
.
space
dup
two
space
dup
8alpha
1+
1+
cr
;
lines
for
one
next
drop
;
dump
x
!
r
show
black
screen
x
@
16
text
lines
keyboard
;
u
-32
x
+!
;
d
32
x
+!
;
extend
system
74
load
macros
76
load
fixes
88
load
stack
rtc
82
load
;
utils
84
load
copy
;
circles
86
load
;
rand
90
load
random
;
lines
92
load
;
htm
102
load
html
;
added
macros
macro
?f
c021
2,
;
0if
75
2,
here
;
+if
78
2,
here
;
1+
40
1,
;
1-
48
1,
;
@b
8a
2,
;
@w
8b66
3,
;
@l
8b
2,
;
!b
a!
288
2,
drop
;
!w
a!
28966
3,
drop
;
!l
a!
289
2,
drop
;
forth ywts
added
macros
?f
set
flags
to
reflect
tos
0if
jnz
aids
in
clarity
+if
js,
this
complements
the
set
1+
increment
tos
1-
decrement
tos
@b
fetch
byte
from
absolute
addr.
@w
fetch
word
from
absolute
addr.
@l
fetch
long
from
absolute
addr.
!b
store
byte
in
absolute
addr.
!w
store
word
in
absolute
addr.
!l
store
long
in
absolute
addr.
corrections
h
sp
20
+
;
oadf
qwerty
save
h
@
100000
h
!
0
dup
nc
@
writes
stop
h
!
;
corrections
h
-a
address
of
dict
pointer,
see
here
also
oadf
save
changed
this
to
keep
the
dictionairy
in
the
same
area.
new
logo
.co
1
3
c
3
a
5*
;
.fo
14
2
1
3
3e
5*
;
cf
27
dup
at
silver
.co
.fo
25
dup
at
red
.co
green
.fo
;
logo
show
black
screen
text
cf
keyboard
;
empty
empt
logo
;
mark
grads
0
128
for
i
2*
1-
color
dup
10
at
5
+
dup
120
box
next
-400
+
128
for
257
i
2*
negate
+
dup
256
*
+
color
dup
10
at
5
+
dup
100
box
next
drop
;
circles
lines
106
load
94
load
lnes
framed
20
for
i
2*
40
+
250
584
ff07
circle
next
filled
30
250
584
f800
circle
framed
ffff
pen
!
art
620
120
at
1020
300
frame
5
120
at
405
300
frame
;
logo
black
screen
grads
lnes
text
cf
show
dotty
fillit
ckb
keyboard
;
empty
empt
logo
;
new
logo
logo
defined
twice.
first
empty
shows
the
fancy
logo
second
entered
empty
shows
the
plain
one.
this
unloads
circles
and
lines.
purely
to
prevent
name
space
crowding.
ascii
cf-ii
addr
6f747200
,
696e6165
,
79636d73
,
7766676c
,
62707664
,
71757868
,
33323130
,
37363534
,
2d6a3938
,
2f7a2e6b
,
2b213a3b
,
3f2c2a40
,
ch
fffffff0
and
unpack
cf-ii
+
@b
ff
and
;
ii-cf
addr
2a00
,
0
,
2b2d0000
,
2725232e
,
1b1a1918
,
1f1e1d1c
,
28292120
,
2f000000
,
3a43352c
,
3d3e3440
,
54523744
,
3336393c
,
38314742
,
3f414632
,
563b45
,
0
,
a130500
,
d0e0410
,
24220714
,
306090c
,
8011712
,
f111602
,
260b15
,
chc
ffffffe0
+
ii-cf
+
@b
ff
and
;
ascii
corrections
to
cf-ii
and
ii-cf
regarding
the
decimals
and
the
letters
k
j
z
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
+
;
rtc
real
time
clock
p@
-n
compile:
in
al,dx
p!
n-
compile:
out
dx,al
rtca
reg-
set
up
rtc
for
acces
to
register
rtc@
reg-n
fetch
reg
from
rtc
rtc!
n
reg-
store
in
rtc
register
hi
wait
till
update
in
progress
bit
is
high
lo
wait
till
uip
bit
is
low
bcd
bcd-n
bcd
to
binary
hms
-n
hours+mins+secs
ymd
-n
year+month+day
day
-n
day
of
the
week
cal
-n
number
of
cpu
clocks
per
second
utils
copy
sf
st
e7c1f88b
,
368b560a
,
b90ae6c1
,
100
,
ad5ea5f3
,
c3ad
2,
rcopy
sf
sl
st
push
dup
push
swap
negate
+
pop
swap
pop
over
+
swap
for
over
over
copy
push
1-
pop
1-
-next
drop
drop
;
utils
copy
from
to-
copy
from
to
block
numbers.
unlike
orig
copy;
no
change
to
blk
rcopy
first
last
to-
multiple
block
copy
routine
circles
c-cd
-8
c-ff
1
point4
4096
*
swap
4
*
2dup
+
2/
negate
bs
@
+
pen
@
over
!w
over
push
+
pen
@
over
!w
+
pen
@
over
!w
pop
negate
+
pen
@
swap
!w
;
opnts
2dup
point4
2dup
swap
point4
;
d?
c-cd
@
?f
drop
-if
;
then
dup
-
c-cd
+!
1-
1
c-ff
!
;
cfl
1+
1+
push
pen
@
swap
pop
2/
for
over
over
!w
1+
1+
next
drop
drop
;
cfl4
4096
*
swap
4
*
2dup
+
2/
negate
bs
@
+
swap
2dup
cfl
push
+
pop
cfl
;
fvrt
?f
drop
if
cfl4
0
c-ff
!
;
then
point4
;
fpnts
2dup
c-ff
@
fvrt
2dup
swap
cfl4
;
points
opnts
;
pntst
addr
points
opnts
fpnts
;
framed
pntst
1
select
;
filled
pntst
2
select
;
circle
0
c-ff
!
pen
!
1024
*
+
2*
vframe
+
bs
!
0
swap
dup
negate
c-cd
!
crcl
less
if
points
1
u+
over
c-cd
+!
d?
crcl
;
then
points
drop
drop
;
circles
point4
..
all
other
words
are
internal.
points
acts
like
a
deferred
word.
pntst
table
of
calls
to
different
point
routines.
select
alters
points
framed
set
circle
to
draw
outlined
circles.
filled
set
circle
to
draw
filled
circles.
circle
rxyc-
draw
circle
with
radius
r
center
xy
in
color
c
stack
juggling
+
misc.
addr
pop
;
rot
8b045e8b
,
46e892e
,
c38b0689
,
c3
1,
-rot
8b045e8b
,
446892e
,
c58b1e89
,
c3
1,
tuck
swap
over
;
2swap
87085e8b
,
85e891e
,
c3044687
,
2over
89f8768d
,
5e8b0446
,
8b1e8910
,
c30c46
3,
2dup
over
over
;
v-
push
-
1+
u+
pop
-
1+
+
;
vn
push
rot
less
if
rot
pop
-rot
;
then
-rot
pop
;
vframe
1e80000
;
pen
65535
bs
32461510
vloc
2048
*
over
+
+
vframe
+
;
point
vloc
pen
@
swap
!w
;
at?
xy
@
10000
/mod
swap
;
@r
1+
dup
4
u+
@l
+
;
!r
1+
dup
push
negate
-4
+
+
pop
!l
;
select
5
*
over
+
@r
swap
@r
!r
;
ckb
black
0
740
at
1024
768
box
800
650
at
1023
740
box
;
stack
juggling
words.
small
and
fast.
addr
-a
absolute
address
rot
abc-bca
stack
pictures
are
best
..
-rot
abc-cab
..described
with
letters,
in
tuck
ab-bab
..this
case.
2swap
abxy-xyab
2over
abxy-abxyab
2dup
ab-abab
v-
v1v2
-
v1-v2
vector
subtract.
vn
vv-vv
sort
vectors
so
x1
is
less
x2
vframe
-addr
address
of
screen.
pen
-addr
current
color.
bs
-addr
base
for
elements
vloc
xy-a
convert
xy
into
addr.
point
xy-
set
point
at
xy
to
current
pen.
at?
-xy
return
current
screen
location.
@r
a-a
get
absolute
addr
from
jump/call
!r
aa-
set
jump/call
to
absolute
addr.
select
an-
select
call
n
from
table
a.
store
it
in
table
call
0
random
rsav
2107951961
rseed
-526774649
rand
time
rsav
!
e09a0e87
rseed
!
;
ror
d3adc88b
,
c3c8
2,
random
push
rseed
@
0
32
for
2*
swap
2*
swap
-if
rsav
@
or
then
next
nip
15
ror
dup
rsav
!
abs
pop
mod
;
rand
random
rand
-
set
random
variables
ror
nm-n
rotate
n
m
times
right
random
n-0..n-1
return
a
random
number
range
0..n-1
limited
to
a
16
bit
number.
lines
ax
-1068
ay
0
sx
2048
sy
2
lbase
32014376
macro
lp
8b02e2c1
,
c88bade8
,
205a8bad
,
232b8966
,
30578c0
,
185a0302
,
3084203
,
ece2105a
,
;
forth
!base
2048
*
over
+
+
vframe
+
lbase
!
;
bline
abs
2*
dup
ay
!
over
2*
negate
ax
!
over
negate
+
swap
1+
pen
@
ax
a!
lp
drop
;
?xd
2over
2over
v-
abs
swap
abs
swap
less
drop
drop
-1
if
1+
then
?f
drop
;
!sy
push
?f
pop
-if
negate
then
sy
!
bline
;
xdom
2swap
!base
2
sx
!
2048
!sy
;
ydom
swap
2swap
swap
!base
swap
2048
sx
!
2
!sy
;
aline
?xd
if
vn
2over
v-
xdom
;
then
push
push
swap
pop
pop
swap
vn
2over
v-
ydom
;
line
at?
2over
aline
at
;
frame
at?
2over
drop
over
line
2over
line
2swap
push
drop
over
pop
line
line
;
line
drawing
do
not
mess
with
variables.
they
are
indexed
by
lp.
lp
macro
inner
loop
for
speed.
draws
point
and
moves
location.
!base
x
y
--
set
base
address
bline
dx
dy
--
draw
a
line
using
bresenham
x
dominant
?xd
v1
v2
--
v1
v2
set
flag
if
line
is
x-dominant
!sy
dy
n
--
dy
store
n
in
sy
set
sign
to
match
sign
of
dy
xdom
x
y
dx
dy
draw
an
x-dominant
line
ydom
x
y
dx
dy
draw
a
y-dominant
line
aline
v1
v2
draw
any
straight
line
line
x
y
draw
line
from
current
at
to
xy.
moves
at
to
given
xy.
frame
xy-
trace
outline
of
rectangle
with
corners
at
and
xy.
pen
position
is
not
altered.
demos
xlate
384
+
512
u+
;
xat
xlate
at
;
xline
xlate
line
;
4lines
over
0
xat
0
over
xline
over
-
1+
0
xline
-
1+
0
swap
xline
0
xline
;
art
70
for
71
i
-
1+
+
5
*
i
5
*
4lines
next
;
rand
radius
8
;
lrc
push
dup
dup
+
negate
pop
+
random
+
;
shade
2over
1+
1+
2over
drop
1+
1+
1+
0
circle
circle
;
dotty
filled
100
for
radius
random
dup
397
lrc
621
+
over
176
lrc
121
+
ffff
random
shade
next
;
blbx
black
6
121
at
404
299
box
;
xyzz
-177
fillit
-1
xyzz
+!
xyzz
@
200
+
drop
-if
blbx
0
xyzz
!
then
framed
3
for
8
random
2
+
dup
398
lrc
6
+
over
178
lrc
121
+
ffff
circle
next
6
210
fff0
random
afill
;
html0
80
load
h-dd
0
ppt
8
macro
2/s
?lit
e8c1
2,
1,
;
forth
temit
h-dd
@
!b
1
h-dd
+!
;
tspc
20
temit
;
.dc
?f
1
-if
-
then
swap
abs
dcl
10
/mod
swap
30
+
push
?f
0if
drop
?f
drop
-if
2d
temit
then
pop
temit
;
then
dcl
pop
temit
nop
;
.hx
39
over
15
and
30
+
less
nip
if
27
+
then
push
4
2/s
0if
drop
pop
temit
;
then
.hx
pop
temit
nop
;
strt
dup
@b
ff
and
if
temit
1+
strt
;
then
drop
drop
;
str:
pop
strt
;
header
str:
6d74683c
,
3c0a3e6c
,
6b6e696c
,
6c657220
,
7974733d
,
6873656c
,
20746565
,
65707974
,
6574223d
,
632f7478
,
20227373
,
66657268
,
3d
1,
6c6f6322
,
6f66726f
,
2e687472
,
22737363
,
703c0a3e
,
a3e
3,
trailer
str:
74682f3c
,
a3e6c6d
,
0
1,
html0.
block
80
has
ascii
conversion
tables.
h-dd
data
destination.
ppt
pre-
parsed
type.
2/s
macro,
right
shift
by
n.
temit
c-
emit
char
to
target.
tspc
emit
space
.dc
n-
signed
decimal
print.
recursive!
dcl
dec
print
loop.
.hx
n-
unsigned
hex
print.
also
recursive.
both
routines
have
no
leading
zeroes.
strt
a-
print
bytes
from
address
until
first
null
byte.
str:
output
what
follows
up
to
null
byte.
header
lay
down
html
header
to
display
blocks.
the
header
is
very
minimal.
it
expects
colorforth.css
in
the
same
directory.
trailer
closing
html
stuff.
html1
.code
1-
drop
-if
;
then
str:
6f632f3c
,
3e6564
,
.all
str:
646f633c
,
6c632065
,
3d737361
,
0
1,
same?
ppt
@
over
ppt
!
swap
over
-
1+
+
drop
;
comn
same?
0if
drop
tspc
pop
drop
;
then
.code
.all
;
.def
str:
3e666564
,
20
2,
.com
2
comn
str:
3e6d6f63
,
20
2,
.chx
3
comn
str:
3e786863
,
20
2,
.exe
4
comn
str:
3e657865
,
20
2,
.xhx
5
comn
str:
3e786878
,
20
2,
.cpm
6
comn
str:
3e6d7063
,
20
2,
.var
7
comn
str:
3e726176
,
20
2,
.txt
8
comn
str:
3e747874
,
20
2,
.txc
9
comn
str:
3e637874
,
20
2,
.tac
10
comn
str:
3e636174
,
20
2,
html1
.code
n-
output
/code
in
brackets
if
n
is
larger
then
0.
.all
common
part
to
start
a
new
code
tag.
same?
n-o
set
ppt
to
the
new
type.
return
the
old
type
with
flags
set
from
comparison.
comn
n-
if
this
is
a
new
tag,
close
prev
tag
and
print
common
part.
if
not:
print
space
and
exit
caller
.def
each
of
these
words
correspond
to
a
.com
..
code
tag
as
defined
in
colorforth.css
.chx
..
the
numbers
are
positional,
and
bare
.exe
..
no
correspondence
to
the
pre
parsed
.xhx
..
types.
they
will
output
if
a
change
.cpm
..
in
tag
is
required.
comn
will
exit
.var
..
by
doing
a
pop-drop
if
the
tag
is
the
.txt
..
same.
.txc
.tac
html2
.str
ch
if
temit
.str
;
then
drop
drop
;
bs1
0
ppt
!
str:
3e72683c
,
6c627b0a
,
206b636f
,
0
1,
bs2
str:
643c0a7d
,
63207669
,
7373616c
,
786f623d
,
a3e
3,
bend
ppt
@
.code
str:
69642f3c
,
a3e76
,
.br
1-
drop
-if
;
then
str:
3e72623c
,
a
2,
pp0
.str
;
pp1
.exe
.str
;
pp3
ppt
@
dup
.code
.br
1
ppt
!
.all
.def
.str
;
pp4
.com
.str
;
pp7
.cpm
.str
;
pp9
.txt
.str
;
ppa
.txc
.str
;
ppb
.tac
.str
;
ppc
.var
.str
1+
dup
@
.com
.dc
;
html2
.str
n-
unpack
n
and
print
as
ascii.
bs1
clear
the
type
and
print
html
stuff
for
the
start
of
a
block.
bs2
second
half
of
block
header.
bend
block
end
html
stuff.
.br
n-
html
line
break,
if
n
larger
then
0
pp0
the
preparsed
words
in
a
block
are
pp1
..
printed
by
the
ppn
words.
eg
pp0
is
pp3
..
word
continuation
pp1
is
for
executed
pp4
..
words,
etc.
they
unpack
and
print.
pp7
..
they
also
print
html
tags.
pp9
ppa
ppb
ppc
html3
96
load
98
load
100
load
dbn
push
1+
dup
@
pop
?f
drop
;
sln
dup
2/
2/
2/
2/
2/
swap
16
and
drop
;
xnb
if
.xhx
.hx
;
then
.exe
.dc
;
cnb
if
.chx
.hx
;
then
.com
.dc
;
pp2
dbn
xnb
;
pp5
dbn
cnb
;
pp6
sln
cnb
;
pp8
sln
xnb
;
ppdo
jump
pp0
pp1
pp2
pp3
pp4
pp5
pp6
pp7
pp8
pp9
ppa
ppb
ppc
;
index
dup
15
and
dup
push
or
pop
;
dblk
dup
bs1
.dc
bs2
block
begin
dup
@
?f
0if
drop
drop
bend
;
then
index
ppdo
1+
end
hbuf
2000
block
;
html
hbuf
4
*
h-dd
!
header
swap
over
for
over
i
-
1+
+
over
+
dblk
next
drop
drop
trailer
hbuf
h-dd
@
3
+
4
/
over
-
1+
+
3
for
tspc
next
;
html3
dbn
an-an
fetch
next
word.
set
hex
flag.
sln
n-n
make
full
word
and
set
hex
flag.
xnb
n-
print
n
as
hex/dec
executed
number.
cnb
n-
print
n
as
hex/dec
compiled
number.
pp2
an-a
a
double
executed
number.
pp5
an-a
a
double
compiled
number.
pp6
n-
a
single
compiled
number.
pp8
n-
a
single
executed
number.
ppdo
table
of
words.
the
index
is
the
pre-
parsed
type
type.
index
n-ni
extract
index
from
n.
dblk
b-
print
block
b
in
html.
hbuf
-a
start
of
buffer.
html
bn-al
output
n
blocks
starting
with
block
b
in
html.
leaves
addr
and
length
on
the
stack,
so
it
can
be
saved
using
file
put
on
a
floppy.
simpler
and
slower
bresenham
line
drawing.
for
reference.
ax
-360
ay
0
sy
2
sw
0
bpoint
push
2dup
sw
@
?f
drop
if
swap
then
point
pop
;
bline
abs
2*
dup
ay
!
over
2*
negate
ax
!
over
negate
+
swap
1+
for
bpoint
?f
+if
sy
@
u+
ax
@
+
then
ay
@
+
push
1
u+
pop
next
drop
drop
drop
;
?xd
2over
2over
v-
abs
swap
abs
swap
less
drop
drop
-1
if
1+
then
?f
drop
;
!sy
push
?f
pop
-if
negate
then
sy
!
bline
;
xdom
0
sw
!
1
!sy
;
ydom
1
sw
!
1
!sy
;
aline
?xd
if
vn
2over
v-
xdom
;
then
push
push
swap
pop
pop
swap
vn
2over
v-
ydom
;
area
filling
108
load
tfc
22461
fc
24071
pset
dup
dup
@w
ffff
and
tfc
@
negate
+
drop
if
drop
0
;
then
fc
@
swap
!w
0
1+
;
bcup
dup
2047
and
2-
begin
-if
drop
;
then
push
2-
pset
drop
pop
if
2-
*end
then
drop
2+
;
ispan
pset
if
;
then
push
enstak
pop
;
xgr
dup
negate
3
pick
+
drop
;
nispan
dlrlx
xgr
-if
5drop
pop
pop
pop
drop
drop
drop
;
then
pset
if
push
nip
dup
pop
then
;
dosp
dlrlx
jump
nispan
ispan
dlrlxi
;
sha2
over
rtre
begin
dlrlxic
-if
drop
;
then
push
dosp
2
u+
pop
2-
end
sha1
dlr
over
pset
over
dlrxil
if
bcup
dlrxil
then
swap
push
swap
2+
pop
dlrlxi
sha2
?f
drop
if
enstak
then
5drop
;
sha
begin
fst?
if
fpop
sha1
*end
then
;
fsln
dup
bcup
swap
dup
rtre
begin
-if
drop
;
then
push
pset
drop
if
2+
pop
2-
*end
then
pop
drop
2-
;
afill
fstini
fc
!
vloc
dup
@w
ffff
and
tfc
!
fsln
over
over
-2048
u+
-2048
+
-2048
-rot
fpsh
2048
u+
2048
+
2048
-rot
fpsh
sha
;
area
filling
pset
a-0/1
set
pixel
at
a,
if
pixel
equals
tfc.
return
0
if
not,
1
if
pixel
was
set.
bcup
a-a
adjust
a
until
left
edge
is
found.
limited
to
screen
edge.
ispan
stack
if
the
right
edge
is
found.
xgr
set
neg
flag
if
x
is
greater
then
parent-r
nispan
exit
if
beyond
right
edge
of
span,
else
start
a
new
span.
dosp
dlrlx
-
dlrlxi
jump
table.
sha2
let
x
go
over
each
pixel
and
set
it
or
start/end
new
spans.
sha1
starting
at
left
edge,
find
the
new
left
edge
and
init
x
to
next
pixel.
stack
if
run
into
right
screen
edge
while
in
span.
sha
pop
the
next
span
and
color
it.
fsln
a-lr
starting
at
screen
address
a,
find
the
left
edge
and
right
edge
of
the
seed
line.
color
it
in
the
process.
afill
xyc
starting
with
screen
location
xy,
and
color
c,
fill
the
color
found
there
with
c
until
the
color
found
changes.
fillstack
fstak
369818
fstakn
0
fstini
here
2/
2/
1024
+
fstak
!
0
fstakn
!
;
fpop
fstak
@
3
for
dup
@
swap
1-
next
fstak
!
-3
fstakn
+!
;
fpsh
3
for
1
fstak
+!
fstak
@
!
next
3
fstakn
+!
;
fst?
fstakn
@
?f
drop
;
fstini
macro
pick
86048b
3,
;
2-
1-
1-
;
2+
1+
1+
;
forth
5drop
drop
drop
drop
drop
drop
;
rtre
2047
and
negate
2048
+
;
enstak
dlrlr
-
dlrlr
2-
4
pick
dup
3
pick
+
over
3
pick
+
fpsh
over
4
pick
negate
+
2+
drop
-if
4
pick
negate
dup
3
pick
+
over
6
pick
2-
+
fpsh
then
2
pick
over
negate
+
drop
-if
4
pick
negate
dup
4
pick
2+
+
over
3
pick
+
fpsh
then
2+
;
fillstack:
stack
of
spans
to
fill.
fstini
initialize
fpop
pop
the
next
element
from
the
stack
fpsh
push
element
on
the
stack
fst?
set
0
flag
if
emtpy.
pick
copy
n
from
the
stack.
2-
screen
pixels
are
2
bytes.
2+
5drop
unload
forth
stack.
rtre
a-n
return
remaining
to
right
screen
edge.
enstak
dlrlr-dlrlr
push
a
span
or
element
onto
the
stack.
also
push
a
left
hand
direction
reversal
and
a
right
hand
reversal
if
needed.
110
term
lines
macro
2/s
?lit
e8c1
2,
1,
;
forth
@w
@w
ffff
and
;
ivrom
22
2
*
*
156
block
4
*
+
;
allot
align
nop
here
push
for
0
,
next
pop
;
4000
2
*
4
/
allot
cbuf
white
;
5
allot
4
/
dup
tecd
white
;
1
+
dup
tecp
white
;
1
+
dup
bpen
white
;
1
+
dup
tmode
white
;
1
+
escmd
white
;
telofs
24
;
tetofs
20
;
cwipe
at?
12
u+
22
+
black
bpen
@
?f
drop
if
white
then
box
;
bit12
@w
12
for
8000
?
if
over
pen
@
swap
!w
then
2*
2
u+
next
drop
;
22lin
rs
22
for
over
i
negate
22 tt
2*
+
bit12
2048
-12
2
*
+
+
next
drop
drop
;
ten
c
cwipe
ivrom
at?
vloc
22lin
space
12
0
+at
;
sfgbg
pen
@
bpen
@
pen
!
bpen
!
;
111
term
2/s
n
shift
tos
n
times
right.
@w
a-n
absolute
16bit
fetch.
masked.
ivrom
c-a
index
into
virtual
rom
allot
n-a
allot
n
32b
words,
leaves
byte
addr.
cbuf
constant
addr
of
double
buffer
white
is
phoney.
buffer
is
16bit/char
tecd
term
emu
cursor
display
location.
tecp
cursor
position.
bpen
background
color,
used
as
a
flag.
tmode
mode,
such
as
normal,
inverse,
bold
etc
escmd
flag
for
esc
mode.
telofs
term
emu
left
offset
tetofs
term
emu
top
offset
cwipe
erase
char
position
to
background.
bit12
one
scan
line
of
a
char.
22lin
rs
display
22
lines
from
char
rom
addr
r
to
screen
addr
s.
ten
c
display
char
c
in
pen
color.
space
advance
screen
loc
one
char.
sfgbg
switch
forground
and
background
colors.
112
term
tei
sfgbg
ten
sfgbg
;
teb
dup
push
ivrom
at?
1
u+
1-
vloc
pop
ten
22lin
;
teu
push
at?
pop
ten
20
+
over
11
+
over
aline
;
teiu
sfgbg
teu
sfgbg
;
temit
cm
jump
ten
tei
teb
teu
teiu
ten
ten
ten
?emit
c
if
dup
7f
and
swap
8
2/s
7
and
temit
;
then
drop
space
;
newc?
a-c
dup
@w
swap
push
dup
pop
4000
+
over
over
@w
or
drop
!w
;
1line
n
telofs
over
22
*
tetofs
+
at
80
2
*
*
cbuf
+
80
for
i
negate
80
+
2*
over
+
newc?
?emit
next
drop
;
c/l
80
;
c/win
c/l
24
*
;
curs*
tecd
@
c/l
/mod
push
12
*
telofs
+
pop
22
*
tetofs
+
0
+
;
curln
2/
2/
6
for
dup
i
negate
6
+
+
-1
over
@
or
swap
!
next
drop
;
cursr
curs*
vloc
18
for
dup
curln
2048
+
next
drop
;
cat?
tecp
@
c/l
/mod
swap
;
linum
tecp
@
c/l
/
;
c+-
n
tecp
@
+
0
max
c/win
-1
+
min
tecp
!
;
cat
lc
c/l
-1
+
min
0
max
swap
23
min
0
max
c/l
*
+
tecp
!
;
caddr
tecp
@
2*
cbuf
+
;
113
tei
c
display
char
c
inverse
color.
teb
c
display
char
c
bold.
teu
c
display
underlined
char.
teiu
c
right.
inverse
underlined.
temit
cm
jump
table
into
char
display
mode
?emit
a
display
char
at
a
if
it
was
changed.
newc?
a-c
returns
char
c
and
sets
flag
if
it
was
newly
added.
1line
n
display
one
line
of
80
chars.
uses
a
double
buffer
to
only
update.
buffer
is
16b/char
for
mode
info.
c/l
80
char
per
line
c/win
24
lines
of
80
chars.
curs*
-xy
returns
cursor
diplay
location.
curln
a
xors
one
line
of
the
cursor
on
the
screen.
cursr
xors
the
screen
info
to
display
a
cursor,
or
turn
it
off.
cat?
-lc
report
cursor
position.
linum
-l
return
current
linenumber.
c+-
n
add
n
to
cursor
position,
wraps
at
edge.
cat
lc
direct
cursor
positioning.
caddr
-a
return
cursor
addr
in
buffer.
114
term
+mode
c-n
tmode
@
256
*
or
;
ech
32
cbf!
c
+mode
caddr
!w
;
echs
push
32
+mode
caddr
pop
for
over
over
!w
2
+
next
drop
drop
;
after
-n
cat?
nip
-
c/l
+
;
eeol
after
1+
echs
;
eeop
23
linum
negate
+
80
*
after
+
1+
echs
;
cr
linum
0
cat
;
cuu
cat?
-1
u+
cat
;
cud
cat?
1
u+
cat
;
cuf
cat?
1+
cat
;
cub
cat?
1-
cat
;
cuh
0
tecp
!
;
epage
cuh
c/win
echs
;
lsadr
n-a
c/l
2
*
*
cbuf
+
2/
2/
;
lcopy
ft
push
lsadr
pop
lsadr
c/l
2/
for
over
@
over
!
1
u+
1+
next
drop
drop
;
scrup
linum
dup
for
i
negate
over
+
dup
1+
swap
lcopy
next
0
cat
eeol
;
scrdn
linum
dup
negate
23
+
for
dup
i
+
dup
1-
swap
lcopy
next
0
cat
eeol
;
cri
linum
?f
drop
if
cuu
;
then
cat?
nip
scrdn
c+-
;
115
+mode
c-n
stick
current
mode
in
the
high
byte.
ech
erase
char
at
cursor,
doesnt
move
cursor.
cbf!
c
put
char
c
in
char
buffer.
echs
n
erase
n
char
,
as
in
ech.
after
-n
number
of
chars
after
cursor
to
right
edge
eeol
erase
from
cursor
to
eol
without
moving
cursor.
eeop
erase
from
cursor
to
end
of
display.
cr
move
to
first
column
current
line.
cuu
cursor
up
one
line.
cud
cursor
down
one
line.
cuf
cursor
fwd
one
char.
cub
cursor
back
one
char.
cuh
home
cursor.
epage
moves
to
home
and
erase
display.
lsadr
n-a
return
cf
addr
of
line
n
lcopy
ft
copy
line
f
to
line
t.
scrup
scroll
up
from
current
line,
erase
current
line
.
scrdn
scroll
down.
cri
same
as
cuu
but
scroll
at
the
top.
116
term
110
load
112
load
114
load
dca
2
escmd
!
;
dca1
-32
+
4
escmd
!
;
dca2
-32
+
0
escmd
!
cat
;
tab
cat?
dup
8
mod
negate
8
+
+
cat
;
linef
linum
1+
dup
0
cat
-24
+
drop
-if
;
then
scrup
;
doctl
jump
cub
tab
linef
linef
linef
cr
esc?
c-
dup
27
or
drop
if
;
then
drop
escmd
@
1
or
escmd
!
pop
drop
;
cntrl
-8
+
-if
drop
;
then
dup
negate
d
-8
+
+
drop
-if
drop
;
then
doctl
;
noesc
dup
-32
+
drop
-if
cntrl
;
then
dup
negate
126
+
drop
-if
drop
;
then
cbf!
1
c+-
;
nul
;
doesc
c
jump
cuu
cud
cuf
cub
epage
nul
nul
cuh
cri
eeop
eeol
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
dca
nul
inesc
escmd
@
1
or
escmd
!
90
min
-65
+
-if
drop
;
then
doesc
;
aemit
esc?
escmd
@
7
and
jump
noesc
inesc
dca1
nul
dca2
nul
nul
nul
trfr
telofs
-4
+
tetofs
-4
+
at
telofs
80
12
*
+
4
+
tetofs
22
24
*
+
2
+
frame
;
trmini
black
screen
ffff
pen
!
trfr
tecp
@
tecd
!
cursr
;
term
cursr
24
for
i
negate
24
+
1line
next
tecp
@
tecd
!
cursr
ckb
;
117
term
dca
direct
cursor
addressing.
dca1
first
dca
parameter.
dca2
second
dca
parameter.
tab
tab
to
next
8
char
stop.
linef
goto
next
line
left
margin,
scroll
if
required.
doctl
jump
table
for
control
chars.
esc?
c
handle
esc
char.
cntrl
c
handle
control
chars.
cr
returns
to
col
0.
lf
to
next
line
col
0.
noesc
c
normal
mode
char
processing.
control
char
are
handled
del
is
ignored
and
dropped.
nul
nothing.
doesc
c
jump
table
for
esc
mode
chars.
only
char
a
to
z
are
used.
most
are
currently
mapped
to
nul.
inesc
esc
mode
char
processing.
aemit
c
depending
on
esc
mode
process
chars.
trfr
draws
frame
around
terminal.
trmini
erase
screen
and
draw
term
window
frame.
term
the
interface
word.
use
like
in:
:dada
trmini
show
app
term
keyboard
;
where
app
is
the
application.
cfvtlp
empty
shft
0
0
shft
!
eflag
1
0
eflag
!
rbuf
1487188
prb
1487264
dbuf
1487264
ncrs
24
ft
1
0
ft
!
cmlogo
logo
;
cmempty
empty
;
extend
72
load
;
termtest
116
load
;
interrupt
142
load
;
com1
3f8
150
load
;
ascii
152
load
;
displaybuf
134
load
132
load
;
rcvbuf
144
load
;
extend
termtest
interrupt
com1
init
ascii
displaybuf
rcvbuf
recurse
pause
vtlp
?exit
1
ft
!
recurse
;
nulscr
show
1cls
term
pause
;
nulscr
recurse
lp
mode
display
words
exit
cli
cmempty
cmlogo
accept
;
fexit
cli
warm
;
?exit
eflag
@
1
and
drop
if
exit
;
then
;
1cls
ft
@
1
and
drop
if
;
then
trmini
;
vtlp
?exit
dbuf
@
prb
@
negate
+
drop
-if
@dbuf
aemit
+1dbuf
vtlp
;
then
;
vt52
emulation
@dbuf
dbuf
@
@b
ff
and
;
+1dbuf
1
dbuf
+!
;
nul
;
escji
addr
0
,
0
,
1020304
,
0
,
0
,
0
,
0
,
0
,
0
,
esca
cat?
swap
-1
+
swap
cat
;
escb
cat?
swap
1
+
swap
cat
;
escc
1
c+-
;
escd
-1
c+-
;
do52
jump
nul
esca
escb
escc
escd
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
nul
;
?esc
1b
negate
+
drop
if
;
then
+1dbuf
@dbuf
+1dbuf
60
negate
+
escji
+
@b
7
and
do52
;
forth
tggl
t0
@
1
and
;
bb
1
emit
;
rb
2
emit
;
jt
tggl
jump
bb
rb
w
show
black
screen
text
jt
keyboard
;
orst
646304
tnr
0
t0
215456152
div
10
rstn
n
2
*
300
+
block
2*
2*
;
dstn
n
2
*
1
+
300
+
block
2*
2*
;
macro
puall
60
1,
;
poall
61
1,
;
svrst
-n
?dup
c48b
2,
;
rerst
n-
e08b
2,
drop
;
srstn
e08b
2,
;
sdstn
f08b
2,
;
incr3
43
1,
;
incr5
45
1,
;
forth
tdst
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
pop
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
push
;
sr
tnr
@
rstn
srstn
;
sd
t0
@
div
@
2
max
mod
-1
?
drop
if
;
then
tnr
@
dstn
sdstn
tdst
;
dd
tnr
@
2
*
1
+
300
+
block
dump
;
interrupts
a,
a,
;
idt
200
block
;
138
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;
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
timer
interrupt
140
load
mt
empty
cli
empt
;
cli
cli
;
sti
sti
;
macro
p@
picp@
0
ec
1,
;
p!
picp!
ee
1,
drop
;
forth
!pit
43
a!
34
p!
40
a!
0
p!
0
p!
;
!pit
0pic1!
20
a!
p!
;
0pic2!
a0
a!
p!
;
pic1!
21
a!
p!
;
pic2!
a1
a!
p!
;
!pic
cli
init
11
dup
20
a!
p!
a0
a!
p!
irq
20
pic1!
28
pic2!
master
4
pic1!
slave
2
pic2!
8086
mode
1
dup
pic1!
pic2!
mask
irqs
ff
pic2!
ed
fa
pic1!
;
!pic
picst
white
700
650
at
21
a!
picp@
h.
space
a1
a!
picp@
h.
700
675
at
a
0pic1!
20
a!
picp@
h.
space
a
0pic2!
a0
a!
picp@
h.
700
700
at
b
0pic1!
20
a!
picp@
h.
space
b
0pic2!
a0
a!
picp@
h.
;
20
interrupt
timer0
cli
incr3
incr5
forth
svrst
orst
!
1
t0
+!
sd
clear
orst
@
rerst
/forth
sti
i;
136
load
sti
a,
n-
empty
interrupt
save
version
cli
disable
interrupts
sti
enable
interrupts
p@
-n
fetch
byte
p!
n-
store
byte
!pit
init
timer0
w/
18.2
hz
!pic
init
pic
timer0
interrupt
subroutine
recieve
buffer
also
loads
keyboard
driver
cli
callot
for
0
1,
next
1
;
mrbuf
here
rbuf
!
ffff
callot
;
rbuf
@
prb
!
rbuf
@
dbuf
!
wiperb
ffff
for
0
rbuf
@
i
+
!b
next
;
+prb
1
prb
+!
;
?rprb
prb
@
rbuf
@
negate
+
ffff
or
drop
if
;
then
wiperb
rbuf
@
dup
prb
!
dbuf
!
;
um
0
pic1!
0
pic2!
;
euart
5
r
serp@
1
and
drop
if
0
r
serp@
ff
and
prb
@
!b
+prb
?rprb
euart
;
then
;
24
interrupt
guart
forth
euart
clear
/forth
i;
148
load
sti
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
+
@b
ff
and
;
ssi
ssc-ii
+
@b
ff
and
;
csi
csi-ii
+
@b
ff
and
;
keyboard
driver
146
load
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
;
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
dup
80
and
drop
if
drop
;
then
sendk
0
r
serp!
;
21
interrupt
ikey
forth
mkey
clear
/forth
i;
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
;