You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

5340 lines
205 KiB

( disk A, side 1 )
code ion ( -> | Turn the interrupts on)
2000 #n sr .w move, next;
code ioff ( -> | Turn the interrupts off)
2700 #n sr .w move, next;
code 2*
sp 2 )d .w lsl, sp ) .w roxl, next;
code 2/
sp ) .w asr, sp 2 )d .w roxr, next;
code shl
sp )+ d0 move, sp ) d1 move, d0 d1 lsl,
d1 sp ) move, next;
code shr
sp )+ d0 move, sp ) d1 move, d0 d1 lsr,
d1 sp ) move, next;
code =
sp )+ sp )+ cmpm, eq
if, -1 #n d0 moveq, d0 sp -) move, next, then,
0 #n d0 moveq, d0 sp -) move, next;
code <>
sp )+ sp )+ cmpm, ne
if, -1 #n d0 moveq, d0 sp -) move, next, then,
0 #n d0 moveq, d0 sp -) move, next;
code 0=
sp ) d0 move, 1 #n d0 subq, d0 d0 subx,
d0 sp ) move, next;
code 0<
sp ) d0 .b move, d0 d0 .b add, d0 d0 subx,
d0 sp ) move, next;
code <
0 #n d0 moveq, sp )+ sp )+ cmpm, lt
if, -1 #n d0 moveq, then, d0 sp -) move, next;
code >
0 #n d0 moveq, sp )+ sp )+ cmpm, gt
if, -1 #n d0 moveq, then, d0 sp -) move, next;
code u<
0 #n d0 moveq, sp )+ sp )+ cmpm, cs
if, -1 #n d0 moveq, then, d0 sp -) move, next;
code *
sp )+ d0 move, d0 d1 move, mi
if, d1 .w neg, d0 neg, then,
sp ) d2 move, mi if, d2 neg, then, d2 d3 move,
d0 swap, d2 swap,
d3 d0 .w mulu, d1 d2 .w mulu, d1 d3 .w mulu,
d3 swap, d2 d3 .w add, d0 d3 .w add, d3 swap,
d1 sp ) eor, mi if, d3 neg, then,
d3 sp ) move, next;
code sp@
sp sp -) move, next;
code sp!
sp0 #n sp move, 0 #n d0 moveq, d0 sp ) move, next;
code rp@ ( -- addr )
rp sp -) move, next;
code rp! ( rp0 -- )
sp )+ rp move, next;
code inrange ( s e n -> fl | True if s <= n <= e, false otherwise)
sp )+ d1 move, sp )+ d2 move, sp )+ d0 move, ( d0: n, d1: e, d2: s )
0 #n d3 moveq, ( set flag false initially )
d1 d0 cmp,
le if, d2 d0 cmp, ( passed one test)
ge if, -1 #n d3 moveq, then, ( passed both tests)
then, d3 sp -) move,
next;
code afilter ( a n -> | filter n bytes from a & put .'s for non-printables)
sp )+ d0 move, sp )+ a0 move, 0 #n d1 moveq,
1 bra,
begin, a0 d0 0 xl)d d1 .b move, 20 #n d1 cmp, lt
if, 2e #n a0 d0 0 xl)d .b move, else, 7f #n d1 cmp, ge
if, 2e #n a0 d0 0 xl)d .b move, then, then,
1 :l
d0 nt -until,
next;
code cmove
sp )+ d0 move, sp )+ a1 move, sp )+ a0 move,
1 #n d0 lsr, cs if, a0 )+ a1 )+ .b move, then,
1 #n d0 lsr, cs
if, a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move, then,
d0 d1 move, d0 swap,
0 .b bra,
begin,
begin, a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move,
a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move,
0 :l d1 nt
-until, d0 nt
-until, next;
( tlh 4/12:12:22 )
frag .move to ( move subroutine, set address)
a1 d1 move, a0 a1 cmp, ls
lif, ( cmove type ) 1 #n d1 .b lsr, cs
if, a0 )+ a1 )+ .b move, 1 #n d2 subq, then,
a0 d0 move, 1 #n d0 .b lsr, nc ( in blocks )
if, 1 #n d2 lsr, d0 d0 .b addx, 1 #n d2 lsr, cs
if, a0 )+ a1 )+ .w move, then,
d2 d3 move, 1f #n d3 .w and, 1 #n d3 .w subq, pl
if, begin, a0 )+ a1 )+ move, d3 nt -until, then,
5 #n d2 lsr, 1 #n d2 .w subq, pl
if, (regs d0 d4 d5 d6 d7 a2 a2 a3 a4 a5 a6 to) sp -) movem,
begin, (regs d0 d1 d3 d4 d5 d6 d7 a2 a3 a4 a5 a6 from) a0 )+ movem,
(regs d0 d1 d3 d4 d5 d6 d7 a2 a3 a4 a5 a6 to) a1 ) movem,
a1 30 )d a1 lea,
(regs d0 d1 d3 d4 d5 d6 d7 a2 a3 a4 a5 a6 from) a0 )+ movem,
(regs d0 d1 d3 d4 d5 d6 d7 a2 a3 a4 a5 a6 to) a1 ) movem,
a1 30 )d a1 lea,
(regs d0 d1 d3 d4 d5 d6 d7 a2 from) a0 )+ movem,
(regs d0 d1 d3 d4 d5 d6 d7 a2 to) a1 ) movem, a1 20 )d a1 lea,
d2 nt -until, (regs d0 d4 d5 d6 d7 a2 a3 a4 a5 a6 from) sp )+ movem,
then,
1 #n d0 .b lsr, cs if, a0 )+ a1 )+ .b move, then, rts,
then, ( otherwise, forward one byte at a time )
1 #n d2 lsr, cs if, a0 )+ a1 )+ .b move, then,
1 #n d2 lsr, cs if, a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move, then,
1 #n d2 lsr, cs
if, a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move,
a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move,
then, d2 d3 move, d2 swap, 1 .b bra,
begin,
begin, a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move,
a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move,
a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move, 1 :l
d3 nt -until,
d2 nt -until, rts,
then,
( move backward )
d2 a0 add, d2 a1 add, a1 d1 move, 1 #n d1 lsr, cs
if, a0 -) a1 -) .b move, 1 #n d2 subq, then,
a0 d0 move, 1 #n d0 .b lsr, nc ( block moves )
if, 1 #n d2 lsr, d0 d0 addx, 1 #n d2 lsr, cs if, a0 -) a1 -) .w move, then,
d2 d3 move, 1f #n d3 .w and, 1 #n d3 .w subq, pl
if, begin, a0 -) a1 -) move, d3 nt -until, then,
5 #n d2 lsr, 1 #n d2 .w subq, pl
if, (regs d0 d4 d5 d6 d7 a2 a2 a3 a4 a5 a6 to) sp -) movem,
begin, 30 #n a0 sub,
(regs d0 d1 d3 d4 d5 d6 d7 a2 a3 a4 a5 a6 from) a0 ) movem,
(regs d0 d1 d3 d4 d5 d6 d7 a2 a3 a4 a5 a6 to) a1 -) movem,
30 #n a0 sub,
(regs d0 d1 d3 d4 d5 d6 d7 a2 a3 a4 a5 a6 from) a0 ) movem,
(regs d0 d1 d3 d4 d5 d6 d7 a2 a3 a4 a5 a6 to) a1 -) movem,
20 #n a0 sub,
(regs d0 d1 d3 d4 d5 d6 d7 a2 from) a0 ) movem,
(regs d0 d1 d3 d4 d5 d6 d7 a2 to) a1 -) movem,
d2 nt -until, (regs d0 d4 d5 d6 d7 a2 a3 a4 a5 a6 from) sp )+ movem,
then,
1 #n d0 .b lsr, cs if, a0 -) a1 -) .b move, then, rts,
then, ( otherwise, backwards by bytes )
1 #n d2 lsr, cs if, a0 -) a1 -) .b move, then,
1 #n d2 lsr, cs if, a0 -) a1 -) .b move, a0 -) a1 -) .b move, then,
1 #n d2 lsr, cs
if, a0 -) a1 -) .b move, a0 -) a1 -) .b move, a0 -) a1 -) .b move,
a0 -) a1 -) .b move,
then, d2 d3 move, d2 swap, 3 .b bra,
begin,
begin, a0 -) a1 -) .b move, a0 -) a1 -) .b move, a0 -) a1 -) .b move,
a0 -) a1 -) .b move, a0 -) a1 -) .b move, a0 -) a1 -) .b move,
a0 -) a1 -) .b move, a0 -) a1 -) .b move, 3 :l
d3 nt -until,
d2 nt -until, rts, ;c
code move ( s d c -> | Move c bytes from s to c, up or down in ram)
sp )+ d2 move, ( d2=count ) le ( count < 1 ?)
if, 8 #n sp addq, ( 2drop source & destination, count < 1)
else, sp )+ a1 move, ( destination) sp )+ a0 move, ( source)
.move jsr,
then, next;
frag .adjust to ( The adjust subroutine adjusts sensitive forth addresses in
68000 assembler code so as to be beneath forth's awareness of what is going
on. The calling code word <move&adjust> , takes the stack values supplied by
purge , retop , behead , etc. and loads the 68000 registers with the correct
values. The registers are set with d0 holding the low ram limit, d1 holding
the high ram limit and d2 the delta byte value to add to any token addresses,
registers or pointers that fall within these limits.)
i' origin a1 move, ( get forth's current origin)
bp .b clr, bp a0 move, ( zero low byte & get 'base' address)
a0 a0 .w add, a0 a0 .w add, ( multiply low word only, by 4)
( this odd procedure gets the token table base into a0)
begin, a0 ) d3 move, ( get an address to compare)
d1 d3 cmp, lt if, d0 d3 cmp, ge if, d2 a0 ) add, ( delta)
then, then, 4 #n a0 addq, ( origin addr) a1 a0 cmp,
ge until,
( The token table goes from the table base -in a0- to forth's origin -in a1-)
( Add the delta in d2 to any registers that need it)
( the address of the last integer invoked, iv, the name of d6)
d1 iv cmp, lt if, d0 iv cmp, ge if, d2 iv add, then, then,
( the currently executing word starting addr., sa, name of d5)
d1 sa cmp, lt if, d0 sa cmp, ge if, d2 sa add, then, then,
( the interpretation pointer, ip, the name of a5)
d1 ip cmp, lt if, d0 ip cmp, ge if, d2 ip add, then, then,
i' endtable #n a0 move, a0 ) d3 move, ( pointer) d1 d3 cmp,
lt if, d0 d3 cmp, ge if, d2 a0 ) add, then, then,
i' strings #n a0 move, a0 ) d3 move, ( pointer) d1 d3 cmp,
lt if, d0 d3 cmp, ge if, d2 a0 ) add, then, then,
i' origin #n a0 move, a0 ) d3 move, ( pointer) d1 d3 cmp,
lt if, d0 d3 cmp, ge if, d2 a0 ) add, then, then,
i' here #n a0 move, a0 ) d3 move, ( pointer) d1 d3 cmp,
lt if, d0 d3 cmp, ge if, d2 a0 ) add, then, then,
i' bound #n a0 move, a0 ) d3 move, ( pointer) d1 d3 cmp,
lt if, d0 d3 cmp, ge if, d2 a0 ) add, then, then,
i' applic #n a0 move, a0 ) d3 move, ( pointer) d1 d3 cmp,
lt if, d0 d3 cmp, ge if, d2 a0 ) add, then, then,
i' newest #n a0 move, a0 ) d3 move, ( pointer) d1 d3 cmp,
lt if, d0 d3 cmp, ge if, d2 a0 ) add, then, then,
i' top #n a0 move, a0 ) d3 move, ( pointer) d1 d3 cmp,
lt if, d0 d3 cmp, ge if, d2 a0 ) add, then, then,
rts,
;c
code move&adjust ( s d c l u del -> | adjust using l u del; move using s d c)
sp )+ d2 move, ( delta, add this if anything is found to be:)
sp )+ d1 move, ( upper limit, less than this)
sp )+ d0 move, ( lower limit, greater than or equal to this)
.adjust jsr, ( bend it)
sp )+ d2 move, ( move count, always positive)
sp )+ a1 move, ( move destination address)
sp )+ a0 move, ( move source address)
.move jsr, ( move it)
next;
code /mod
sp ) d0 move, eq if, next, then, mi
if, d0 neg, then, sp 4 )d d1 move, mi if, d1 neg, then,
d1 d2 move, d0 d2 or, d2 swap, d2 d2 .w or, eq
if, ( use divu ) d0 d1 .w divu, 0 #n d2 moveq,
d1 d2 .w move, ( q ) d1 .w clr, d1 swap, ( rem )
else, 0 #n d2 moveq, 1f #n d3 moveq,
begin, d1 d1 addx, d2 d2 addx,
d0 d2 sub, cs if, d0 d2 add, then, d3 nt
-until, d1 d1 addx, d1 not, d1 d2 exg,
then, sp ) d0 .b move, 4 #n sp addq, d0 sp ) .b eor, mi
if, d1 tst, ne if, 1 #n d1 addq, 1 #n d2 addq, then,
d2 neg,
then, d0 d0 .b or, mi if, d1 neg, then,
d1 sp ) move, d2 sp -) move, next;
: / ( a b -> c | Divide a by b, c is the floored integer result)
/mod nip ;
: mod ( a b -> c | c is the result of a mod b)
/mod drop ;
code digit ( n base --- number/base ascii.digit )
0 #n d1 moveq, sp )+ d0 move, ( d0=base )
sp )+ d1 .w move, ( hi ) d0 d1 .w divu, d1 d3 move,
sp )+ d1 .w move, ( lo ) d0 d1 .w divu, d3 swap,
d1 d3 .w move, ( d3=quot ) d3 sp -) move,
d1 .w clr, d1 swap, ( digit )
0a #n d1 .b cmp, nc if, 7 #n d1 addq, then,
30 #n d1 add, d1 sp -) move, next;
code number ( addr len base --- 0 -or- value -1 )
sp )+ d0 move, sp )+ d1 move, sp ) a0 move,
0 #n d2 moveq, d2 a1 move, d2 d3 move,
1 #n d1 subq, d4 sp ) move, 2d #n a0 ) .b cmpi, eq
if, 1 #n a0 addq, 1 #n a1 subq, 1 #n d1 subq, then,
begin, a0 )+ d3 .b move, 3a #n d3 .b cmp, cs
if, 30 #n d3 .b sub, then, 41 #n d3 .b cmp, nc
if, 37 #n d3 .b sub, 20 #n d3 .b cmp, nc
if, 20 #n d3 .b sub, then,
then, d0 d3 .b cmp, nc ( bad digit )
if, 0 #n d3 moveq, sp ) d4 move, d3 sp ) move, next, then,
d2 d4 move, d0 d2 .w mulu, d4 swap, d0 d4 .w mulu, d2 swap,
d4 d2 .w add, d2 swap, d3 d2 add, d1 nt -until,
a1 d1 move, ne if, d2 neg, then, -1 #n d0 moveq,
sp ) d4 move, d2 sp ) move, d0 sp -) move, next;
code execute
sp )+ d0 move, \int 8 shl #n d0 .w cmp, nc
if, .int \int 8 shl - #n d0 add, d0 iv move,
iv a0 move, a0 ) sp -) move, next,
then,
bp .b clr,
bp a0 move, d0 a0 .w add, a0 a0 .w add, a0 a0 .w add,
a0 ) a1 move, a1 ) jmp, ;c
code +table
bp d0 move, d0 .b clr, sp ) d0 add,
d0 d0 .w add, d0 d0 .w add, d0 sp ) move, next;
code <word> ( start limit delimiter -- string len start' | find next word
delimited by space )
sp )+ d1 move, sp )+ a0 move, ( get parameters )
d4 sp -) move, ( save d4 )
d1 d3 move, a0 d3 sub, ( determine length of region )
d3 swap, d3 d4 .w move, d3 swap, ( also save high order word)
spc #n d0 moveq, ( put a space into d0 )
begin,
begin, a0 )+ d2 .b move, ( skip space or below )
pl if, d0 d2 .b cmp, then, ( includes negatives )
d3 gt -until, ( until have a real character )
d4 gt -until,
a0 d1 cmp, cs if, ( outside of search area? )
sp )+ d4 move, ( restore d4 )
d1 sp -) move, 0 #n d0 moveq, d0 sp -) move, ( str&len )
d1 sp -) move, next, ( &start, then exit )
then, 0 #n d2 moveq, ( clear d2. bit 8 will be a flag )
a0 a1 move, 1 #n a1 subq, ( a1=start of word )
begin,
begin, a0 )+ d2 .b move, ( skip until space or below )
pl if, d0 d2 .b cmp, ( if okay char, check with delim )
else, 100 #n d2 .w move, then, ( if hidden, set flag )
d3 le -until, ( until find a delimiter )
d4 le -until,
a0 d1 cmp, ( see if beyond selection )
cs if, d1 a0 move, else, 1 #n a0 subq, then, ( a0=word end+1)
a1 a0 cmp, ne if, ( if length is greater than 0 )
8 #n d2 btst, ne if, ( and the hidden flag is set )
a2 sp -) move, i' wordbuff a2 move, ( a2=buffer ptr )
a2 d0 move, maxword #n d0 add, ( d0=end of buffer+1 )
a0 d3 move, a1 d3 sub, 1 #n d3 subq, ( d3=counter )
begin, a1 )+ d2 .b move, ( get characters from text )
pl if, d2 a2 )+ .b move, then, ( if ok move to buffer)
d0 a2 cmp, ( see if out of space in buffer )
d3 ge -until, ( until all checked )
i' wordbuff a1 move, ( a1=start of word )
a2 d0 move, sp )+ a2 move, ( d0=end of word + 1 )
else, a0 d0 move, then, ( if didn't get through )
else, a0 d0 move, then, ( d0=regular end of word+1 )
sp )+ d4 move, ( restore d4 )
a1 sp -) move, ( push start of word )
a1 d0 sub, d0 sp -) move, ( determine and push length )
a0 sp -) move, ( and the start of the next word )
next; ( all done )
code <find> ( va sa sl -> addr f |-> addr tok t )
sp )+ d0 move, ( length of string to match )
sp )+ d1 move, ( address of string to match )
sp )+ a0 move, ( starting addr of vocab to search )
(regs a2 d4 d5 d6 to) sp -) movem, ( save registers )
a0 )+ d3 .b move, 8 #n d3 lsl, a0 )+ d3 .b move, 8 #n d3 lsl,
a0 )+ d3 .b move, 8 #n d3 lsl, a0 )+ d3 .b move, ( get length )
a0 d2 move, ( left side to search )
a0 d3 add, 2 #n d3 subq, ( right side to search )
( The remaining registers are: d4 - found string length
d5 - match loop count
d6 - temp
a1 - temporary string pointer)
begin, d2 d4 move, d3 d4 add, 1 #n d4 lsr, d4 a0 move, ( mid )
d4 a2 move, ( copy for backup )
begin, a0 )+ d4 .b move, mi until, ( scan for ct byte )
3f #n d4 and, d1 a1 move, d4 d5 move, ( d5=smaller )
d4 d0 .b cmp, cs if, d0 d5 move, then,
begin, 1 #n d5 .b subq, mi
if, d4 d0 .b cmp, eq if, ( hit ) d0 a0 sub, a0 -) d1 .b move,
-1 #n d2 moveq, d1 d1 .b add, mi if, 1 #n d2 moveq, then,
a0 -) d4 .b move, 0 #n d3 moveq, a0 -) d3 .b move,
7 #n d3 asl, d4 d3 .b or,
(regs a2 d4 d5 d6 from) sp )+ movem, ( restore registers )
a0 sp -) move, d3 sp -) move, d2 sp -) move, next, then, leave,
then, a1 )+ d6 .b move, a0 )+ d6 .b cmp, ne
until, nc
if, a0 d2 move, ( new left bound )
else, begin, a2 -) .b tst, mi until, a2 d3 move,
then, d3 d2 cmp, nc
until, ( right string converged on left )
(regs a2 d4 d5 d6 from) sp )+ movem, ( restore registers )
d2 a0 move, 1 #n a0 addq,
begin, a0 )+ d1 .b move, mi until, 3 #n a0 subq,
a0 sp -) move, ( address )
0 #n d0 moveq, d0 sp -) move, ( false flag )
next;
: hex
10 base to ;
: decimal
0a base to ;
: open?
current 1 < abort" no vocabulary open" ;
: outofroom ( true | n false -- )
not if noroom error abort then ;
: compromise ( need available have -- using flag \ true means enough )
local avail local need local have
have to avail to have - need to ( need to add this much )
need 1 < if 0 -1 exit then ( already enough room )
need dup isize mod ?dup
if - isize + then ( increase to nearest interval )
avail over < ( enough available? )
if drop avail dup isize mod - have + 0 ( no, calc max movable )
else avail need + 2/ ( moving this will equalize boundary )
dup isize 2/ /mod 1 and ( adjust to nearest interval, )
if - isize 2/ + avail over < ( rounding up )
if isize - then ( rounded too far )
else - then ( rounding down )
max -1 then ; ( use larger of two )
: needforth ( n -- true | n -- n' false *** )
local need need to
need bou gap - 5 - applic here - 4 - ( the 5 is for skip marker )
compromise dup 0=
if exit then
swap ?dup
if text swap + endtext move&adjusttext ( get it from the text )
text retop ( and give it to forth )
then ; ( otherwise, there was enough room )
: needtext ( n -- true | n -- n' false *** )
local need need to
need applic here - 4 - bou gap - 5 - ( the 5 is for skip marker )
compromise dup 0=
if exit then ( not enough room )
swap ?dup
if top swap - retop ( if no, get space from forth )
top endtext move&adjusttext ( and give it to the text )
then ; ( otherwise, there was enough room )
: froom? ( n -> )
needforth outofroom ;
: allot ( n -> | Allot n bytes)
open? dup froom? here +to ;
: c, ( b -> | Compile byte b at here)
here 1 allot c! ;
: w, ( w -> | Compile word w at here)
here 2 allot w! ;
: , ( n -> | Compile 4 byte n at here)
here 4 allot ! ;
code <cksum> ( a n -> s | checksum n bytes starting at a, report 32 bit sum)
sp )+ d0 move, d0 swap, d0 d1 .w move, d0 swap, ( get low&high part )
sp )+ a0 move, ( get address )
0 #n d2 moveq, d2 d3 move, ( initialize variables )
1 .b bra, ( and start count )
begin,
begin, a0 )+ d3 .b move, ( get byte )
d3 d2 add, ( and accumulate )
1 :l
d0 nt -until,
d1 nt -until,
d2 sp -) move, next;
code <cksum4> ( a n -> s | checksum n/4 32 bit locations from a, a even)
sp )+ d0 move, 2 #n d0 asr, 1 #n d0 subq,
sp )+ a0 move, 0 #n d1 moveq,
begin, a0 )+ d1 add, d0 nt -until, d1 sp -) move, next;
: romchecksum ( -> s | Report the 1 byte, 32 bit checksum of the rom)
0 [ romsize ] literal <cksum> ;
: ramchecksum ( -> s | Report the 4 byte, 32 bit checksum of all ram)
ramstart ramend over - <cksum4> ;
: blinkruler ( -- )
4 0 ( make sure you do this an even number of times! )
do ruleblink not ruleblink to rule 80 ms loop ;
: error ( addr len -> | )
edde
if xplen to xplint to
%explain curop <>
if beepblink dup 1 and if beep then
2 and if blinkruler then
then
%explain curop to
learnbuff if clr-kbd then
else type then ;
: exa ( t -> addr | fetch token t's 24 bit execution addr, t ranged )
+table dup 0 +table endtable inrange not
abort" meaningless token value" @ ffffff and ; ( 24 bit addrs only )
: window ( n -> | Set forth's window bottom to line n, 1<=n<=1d )
1 max 17 min last4thline to ;
( CRT display words -- new hardware moves right over)
code setcur ( x y -> | Position the cursor at x y )
sp )+ d0 move, ( get y )
scans/char /scan * #n d0 .w mulu,
d0 a0 move,
sp )+ a0 add, ( add x offset )
screen #n a0 add,
scans/char 1- #n d2 moveq, ( all slices of the character )
begin, a0 ) .b not, /scan #n a0 add, d2 nt -until,
next;
( MT 2/19/87 Changed to be ROM only <demit> )
code <demit> ( ch x y -> | Send the character to x and y on the display )
0 #n bp .b move, bp a1 move, a1 a1 .w add, a1 a1 .w add,
i' font d2 move, d2 d2 .w add, d2 d2 .w add,
a1 d2 0 xw)d a1 move, ( addr of current font )
sp )+ d2 move, ( Get y position )
sp )+ d1 move, ( Get x position )
sp )+ d0 move, ( Get character )
( here target - .<demit> to ( Set up pointer for ROM only entry
point )
( When entering through .demit address: )
( D2 = Y position )
( D1 = X position )
( D0 = Character to be displayed )
( A1 = Address of the font to use )
scans/char /scan * #n d2 .w mulu,
d1 d2 add,
screen #n d2 add,
d2 a0 move,
7 #n d0 bclr, ne d1 set, ( hi bit = inverse video )
( NOTE: side-effect of hi-bit hack is no display of foreign chars )
logbytes/char #n d0 asl,
d0 a1 add, ( a1: image of char)
2 #n a1 addq, ( Add offset to skip underline etc. )
scans/char 1- #n d2 moveq, ( process all character slices )
d1 .b tst, ne ( inverted? )
if, ( yes, it's inverted )
begin, a1 )+ d0 .b move, d0 .b not,
d0 a0 ) .b move, /scan #n a0 add,
d2 nt -until, ( next row )
else, ( nope, a plain ol' character )
begin, a1 )+ a0 ) .b move, /scan #n a0 add, d2 nt -until,
then, next;
: <remit> ( char -- raw emit to the screen )
[ bytes/line ] literal * + screen + ( base address )
swap 4 shl font exa + dup
[ scans/char ] literal + swap
do i c@ over c! [ /scan ] literal + loop drop ;
: crlfscroll ( -> | do a display cr-lf with line blanking and maybe scroll )
last4thline window ( can't be too careful! )
x off y 1 max 1+ last4thline min
[ bytes/line ] literal *
1 y +to
y last4thline > ( check to see if we scroll )
if last4thline y to
dup screen [ bytes/line ] literal + screen rot move
then screen +
[ screen bytes/line 18 * + ] literal min ( faster this way )
2- ( chars start at the 2nd char, adjust for it )
[ scans/char ] literal 0 do
dup 54 ff fill dup 54 + [ /scan 54 - ] literal 0 fill
/scan +
loop drop ; ( blank line )
( [ bytes/line ] literal ff fill ; ( blank line )
: pemit ( ch -> | Send the ch out the parallel port of the Cat )
begin [ duart ser.ip + ] literal c@ 10 and ?panic or until ( affects ipcr)
?panic not if [ ga3 pr.data + ] literal c! ( send char & handshake )
else drop then ; ( if panicked out, drop it )
: demit ( ch -> | Display character, do cr's and del's, etc )
x y setcur dup 7f and 1f >
if x y <demit> 1 x +to x 4f >
if crlfscroll lp ( display )
if 0d pemit 0a pemit ( printer on )
then then
else dup 0d =
if drop crlfscroll ( a carriage return )
else 08 =
if -1 x +to x 0< ( a backspace )
if x off then
20 x y <demit> ( blank it )
then then then x y setcur ;
: emit ( ch -> | Output character to active output devices )
crt if dup demit then
lp if dup pemit then
edde if dup eemit then
ser if semit
else drop then ;
code cls ( Clears the screen )
( Assumes active/scan /scan are multiple of 4 )
ramstart #n a0 move,
height 1- #n d2 move, ( Get lines in dispaly )
begin, active/scan 4 / 1- #n d1 move, ( Get bytes per scan line )
-1 #n d0 moveq, ( Fill with ones )
begin, d0 a0 )+ move, d1 nt ( Write to screen )
-until,
/scan active/scan - 4 / 1- #n d1 move, ( Get overscan per line )
pl if, ( only if there is
extra )
0 #n d0 moveq, ( Fill with zeros )
begin, d0 a0 )+ move, d1 nt ( Write to screen )
-until, ( Do all lines )
then,
d2 nt
-until, next;
( end of stuff that just moves over )
: home
x off y off ;
: page
crt if cls home then 0c emit ;
: cr
0d emit 0a emit ;
: space
20 emit ;
: spaces ( n -- , noop out if 0 or negative number )
dup 0 > if dup 0 do space loop then drop ;
: hold
-1 hld +to hld c! ;
: "hold ( addr len -- )
?dup ( verify the string has a length )
if 0 swap 1- ( count down string backward )
do i over + c@ hold -1 +loop ( if so, hold each character )
then drop ; ( and drop the address )
: <#
pad hld to ;
: #
base digit hold ;
: #s
begin # dup 0= until ;
: #>
drop hld pad over - ;
: sign
0< if 2d hold then ;
code ?stack ( -> f | Return false if stack ok, else -1 for empty or 1 full )
-1 #n d0 moveq, sp0 1+ #n sp cmp, cs
if, sp0 stacksize ( depth) - #n sp cmp, nc
if, 0 #n d0 moveq, else, 1 #n d0 moveq, then,
then, d0 sp -) move, next;
: .r ( n w -> | Output signed n in a field w wide )
>r dup abs <# #s swap sign #> r> over - spaces type ;
: u.r ( n w -> | Output n, unsigned, in a field w wide )
>r <# #s #> r> over - spaces type ;
: . ( n -> | Output n as a signed or unsigned number with 1 blank )
dup abs <# #s swap sign #> space type ;
: u.
<# #s #> space type ;
code diff? ( a b n -> 0 | If same. | -> a' -1 | Strings differ at a' )
sp )+ d0 move, 1 #n d0 subq, ( for -until )
sp )+ a0 move, sp )+ a1 move, ( addresses b and a )
begin, a0 )+ a1 )+ .b cmpm, d0 ne -until, ne
if, -1 #n d0 moveq, 1 #n a0 subq, a0 sp -) move,
else, 0 #n d0 moveq,
then, d0 sp -) move, next;
: same? ( a b n -> f | True if strings of length n at a and b same )
diff? dup if nip then 0= ;
code encode
sp )+ d0 move, d0 d0 add, 1 #n d0 .b lsr, d0 sp -) move, next;
code decode
sp )+ d0 move, d0 d0 .b add, 1 #n d0 lsr, d0 sp -) move, next;
: goto ( addr -> | Begin execution at addr. Code must exit with next )
['] temp +table ! ( put addr into table) temp ;
code call ( addr -> | jsr to addr, code there must end in an rts )
sp )+ a0 move, a0 ) jsr, next;
: <deactivate> ( t -> | Deactivate the vocabulary whose token is t )
[ .act #vocs 2* + ] literal active
do dup i w@ =
if i 2+ i [ .act #vocs 2* + ] literal i - cmove leave then
2 +loop drop ;
: vocab ( -> | Move the executing vocabulary to the top of active )
raddr ( get address of executing word )
1+ ( skip over oddness flag )
w@ ( get the token) dup <deactivate> ( if it is active)
active dup 2+ [ #vocs 2* 2- ] literal move ( make room)
active w! ( put at top) ;
: vocab? ( t -> f | Return true if t is the token of a vocabulary )
dup -1 <> if active ( extant's limit) extant do i w@ over =
if ( it is in extant) drop -1 exit then
4 +loop ( not in extant) drop 0 then ;
: vopen ( t -> addr | Return a vocabulary's opening point )
dup vocab? not abort" nonvocabulary" current over <>
current 0< or if ( closed vocabulary) exa 6 + dup @ + 4 +
else ( open vocabulary) drop applic then ;
code temp ;c ( these words are re-assigned inside other code )
code displaytrace ;c ( they are here, so if used before defining, will error)
code displaycodetrace ;c
: freetoken
1 abort" unassigned token " ;
: ]
savenest nesting to savestate state to ;
: [
nesting savenest to state savestate to nesting off state off ;
immediate
: fnderr
0= abort" can't find" ;
: find ( str len -> tok t | found in search order -> f | not found)
local str local ln ln to str to
[ .act #vocs 2* + ] literal active
do i w@ 7fff <
while i w@ vopen str ln <find> ?dup ( has it been found?)
if ( yes) rot drop exit then ( no) drop
2 +loop 0 ;
: word
in limit <word> in to len to str to ;
( old : word in limit rot <word> 2dup + in to len to str to ;)
: compile,
dup 100 u< if c, else w, then ;
: [compile]
word str len find fnderr compile, ;
immediate
: compile
r@ >r ( rdup) raddr ( get actual address)
dup c@ ['] blit < ( 1 or 2 byte token???)
if ( 2 byte) w@ w, r> 2+ ( the delta is in lower half...)
else ( 1 byte) c@ c, r> 1+ ( so the addition works ok)
then >r ( stuff the two 16 bit items back on the return
stack, with the delta ip incremented by 1 or 2) ;
code recycledtoken ( -- token | recycled, points to freetoken, 0 = out of
tokens. If targeting is on: simply return and increment tokens )
i' tokens d1 move, i' ramtoken0 d0 move,
tc' freetoken #n d3 move, i' targeting tst, 1 ne bra,
d0 d1 cmp, 1 lt bra, d0 d1 sub, 1 #n d0 subq,
begin, 1 #n d0 addq, bp d2 move, d2 .b clr, d0 d2 add,
d2 d2 .w add, d2 d2 .w add, d2 a0 move, ( a0 = +table )
a0 ) d3 cmp, ( freetoken's addr? )
eq if, d0 sp -) move, next, then, ( used recycled token )
d1 nt -until, i' endtable d1 move, a0 d1 cmp, lt
if, -1 #n sp -) move, ( out of tokens, return 0 )
else, d3 a0 ) move, ( recycle new token )
1 :l i' tokens #n a0 move, a0 ) sp -) move, ( new token )
1 #n a0 ) addi, then, next; ( imcrement tokens )
: assign ( voc.addr str len --- | assign a token and header )
local ct local str local voc local size
ct to str to dup @ voc to
voc str ct <find>
if lasttok to lasttok exa ['] freetoken exa =
if " resolving "
else targeting 0= if lasttok <becode> then " redefining "
then type str ct type newest to drop
else recycledtoken ( assign a token )
dup -1 = abort" out of tokens "
lasttok to ct 3 + size to ( name size )
size needforth outofroom size - newest to ( header size )
voc voc size - newest size + voc - move ( make room for header )
str newest 3 + ct move ( put in the name string )
size negate over +! ( adjust pointer)
@ dup @ size + swap ! ( adjust vocabulary count )
ct 80 or newest 2+ c! ( set bit 7 & emplace count )
lasttok encode newest w! ( emplace token )
then ;
: align
here 1 and allot ;
: create ( -- )
open? align word applic addr str len assign
here lasttok +table !
patchrom ;
: forward
applic addr str len assign
" creating " type str len type lasttok compile,
targeting 0= if ['] freetoken exa lasttok +table ! then ;
: integer
create 4ed2 w, , ;
: array
create 4e94 w, allot ;
: literal
dup 80 + 100 u< if compile blit c, else dup 10000
u< if compile wlit w, else compile lit , then
then ; immediate
: '
word str len find fnderr ;
: c'
' exa ;
: n'
word applic str len <find> fnderr drop ;
: [']
word str len find fnderr [compile] literal ;
immediate
code sw ( -> | Save the interpreted integer addr while interpreter runs)
oldiv d0 move, iv oldiv move, d0 iv move, next;
: ?stackerr ( -> | Checks stack for over or underflow, issues message)
?stack 0< abort" empty" ?stack abort" full" ;
: rdepth ( -> n | Returns with the number of items on the return stack )
rp0 rp@ - 4 / ;
: depth ( -> n | Returns with the number of items on the stack)
sp@ sp0 ( the order is important) swap - 4 / ;
: .s ( -> | Non-destructivly print stack contents, unsigned if hex )
depth ?dup
if dup 0<
if drop ." underflowed "
else 0
do sp0 4 - i 4 * - @ base 10 =
if ( in hex ) u. else . then
loop then
else ." empty " then ;
: doloc ( -> f | )
localvoc str len <find>
if loops + ?dup
if dup 4 = ( if only one local)
if drop compile <loc1> ( special fast one)
else compile <local> c, ( otherwise an ordinary one)
then
else compile <loc0> ( no locals yet, initial local)
then
drop 0
then ;
: interpret
over + limit to in to
begin str off word len
while locals if doloc else -1 then
if str len find ?dup
if 0< state nesting or and
if compile, else sw execute sw then
else str len base number
if state nesting or if [compile] literal then
else targeting if forward else leave then
then
then
then ?stackerr
again len abort" can't use" ;
( NOTE: if emptyvoc is changed, change tcreatevoc )
code emptyvoc ( -- addr | addr of image of closed empty voc )
nx ) jsr, ( returns addr of next byte, like array )
4ed3 w, t' vocab c, ( begin the definition )
0 c, ( oddness byte for closing odd sized vocabularies )
-1 w, ( dummy token of voc to be stored into active )
0 , 6 , ( size of closed vocabulary, initial headers length )
8100 w, ( tokenless header with the name "null" )
7f7f w, ( largest encoded token ) 817f w, ;c ( "del" )
: ?pairs
<> abort" unpaired" ;
: !csp
sp@ csp to ;
: ?csp
sp@ csp ?pairs ;
: local
locals 0=
if applic 0a - localvoc to
emptyvoc 0a + localvoc 0a cmove ( temp voc )
compile <locals> here location to 0 c,
then tokens >r locals tokens to
word localvoc addr str len assign
4 locals +to r> tokens to ;
immediate
: exit
locals loops + ?dup
if compile <exitlp> c, else compile <exit> then ;
immediate
: nest
nesting state or 0=
if here bound to 4ed3 w, !csp then 1 nesting +to ;
: unnest ( -- )
local oldhere local size -1 nesting +to
nesting state or 0=
if [compile] ; bound oldhere to here oldhere - size to
oldhere execbuf size cmove oldhere here to
execbuf size execbuf +to goto size negate execbuf +to
then ;
: if ( -- ) nest compile <0bran> here 2
FF c, ( indicates that this code was compiled by if )
; immediate
: backelse ( - increment )
temp1 -80 7F inrange ( handle a short else )
if temp0 c@ FE = ( check for short if data )
if temp0 temp0 1+ c@ - ( calculate address of short if data )
dup c@ ( duplicate address, fetch the data )
1- ( short else data, reduce if by one )
swap c! ( put reduced if data in place )
else temp0 temp0 w@ - ( calculate address of long if data )
dup w@ ( duplicate address, fetch the data )
1- ( short else data, reduce if by one )
swap w! ( put reduced if data in place )
then
( else -> then is short; move the else -> then code back one )
( to recover 2nd byte of else data area )
temp0 1+ temp0 temp1 1- move ( src dest count )
-1 allot ( use 1 less byte of code space )
-1 ( code has moved by -1 increment )
temp1 1- temp0 c! ( fill in short else data )
else
['] <branl> temp0 1- c! ( replace <bran> with <branl> )
temp1 2- temp0 w! ( fill in long else data ) 0
( code has moved by 0 increment )
then swap ; ( swap increment and else/then flag )
: {elsethen} ( address identifier conditionalflag - increment )
0 >r ( put marker on return stack )
begin swap dup 4 = ( put identifier on top of the stack )
while >r swap >r ( move leave and while data to ret stack )
again 2 ?pairs ( check for matching control structures )
dup ( is this being used by else or then ? )
if compile <bran> 0 w, then
swap temp0 to ( save the address of the if or else data )
here temp0 - temp1 to ( save delta distance to the if or else data )
temp0 c@ FF = ( are we backfilling an if ? )
if temp1 -80 7F inrange ( are we backfilling a short if branch ? )
if temp1 temp0 c! ( fill in byte if data )
0 ( no code movement is required )
swap dup ( else or then ? )
if FE here 2- c! ( this code means a short if precedes )
( this else and that the byte offset )
( to the if data follows this code )
here 2- ( address of the start of else data )
temp0 - ( distance between start of if data )
( and start of else data )
here 1- c! ( store short offset into memory )
( immediately after the FE code byte )
then
else ( we are backfilling a long if branch )
['] <0branl> temp0 1- c! ( change <0bran> to <0branl> )
temp0 1+ temp0 2+ temp1 1- move ( src dest count )
( move if -> then code up 1 to accomodate the 2 byte if data )
1 allot ( we use 1 more byte of code space )
1 ( code has moved +1 bytes )
temp1 ( 1+ ) temp0 w! ( backfill word if data )
swap dup ( else or then ? )
if here 2- ( start of else data )
temp0 ( start of if data )
- ( distance between the two )
here 2- w! ( save distance in else data spot )
then then
else backelse then
drop ( drop the else / then flag )
temp0 to ( save away the value by which the while and )
( leave addresses on the stack should be incremented )
begin r> ?dup ( any while or leave data on the return stack ? )
while temp0 + r> ( add increment value to the address )
again ;
: else ( -- a n )
-1 ( '-1' means else to {elsethen} )
{elsethen} here 2- 2 ; immediate
: then ( -- )
0 ( '0' means then to {elsethen} )
{elsethen} unnest ; immediate
: {while} ( token1 token2 - address 4 )
nestype if swap
then drop c, ( compile the remaining token )
here 4 ( leave address of while or leave data and a 4 )
0 w, ; ( leave 2 byte space for while or leave data )
: while ( - address 4 )
['] <0branl> ['] <0leavel> {while} ; immediate
: leave ( - address 4 )
['] <branl> ['] <leavel> {while} ; immediate
: {loop} ( nestypeflag address identifier token - )
temp0 to temp1 to ( temp0: token ; temp1: identifier )
0 >r ( put marker on return stack )
begin dup 4 =
while swap >r >r ( move leave and while data to ret stack )
again
temp1 ?pairs temp0 c, ( lay down token. will be either a <bran> , )
( <0bran> , <loop> , or a <+loop> )
temp0 ['] <bran> = temp0 ['] <0bran> = or
if here - temp1 to ( save negative delta distance in temp1
)
temp1 -80 7F inrange
if ( handle short begin loops )
temp1 c, ( compile delta branch distance )
else ( handle long begin loops )
temp0 ['] <bran> =
if ['] <branl> here 1- c! ( replace <bran> with <branl> )
temp1 2- w, ( because <branl> is wrong )
else ['] <0branl> here 1- c! ( change <0bran> to <0branl> )
temp1 1- w, ( because <0branl> is wrong )
then then then nestype to
begin r>
while here r@ - ( calc dist between while or leave data and here )
r@ 1- c@ ( get while or leave token )
['] <branl> =
if 2- ( because <branl> is wrong )
else 1- ( because <0leavel> and <leavel> are wrong )
then r> w! ( backfill while or leave data )
again ;
: until ( -- ) 1 ['] <0bran> {loop} unnest ; immediate
: again ( -- ) 1 ['] <bran> {loop} unnest ; immediate
: loop ( -- ) 3 ['] <loop> {loop} -0C loops +to unnest ; immediate
: +loop ( -- ) 3 ['] <+loop> {loop} -0C loops +to unnest ; immediate
: do
nest 0c loops +to compile <do> nestype 3 -1 nestype to ;
immediate
: begin
nest nestype here 1 0 nestype to ;
immediate
: <abort"> ( f s l -> | The execution part of abort")
rot if edde
if error str bot nextchar gap prevchar inrange
str c@ 80 < and
if collapse str op to extend then
str off
else type space str len type
then abort
else 2drop then ;
: immediate ( -> | Set bit 6 of the newest word so it executes in :)
40 newest 2+ or! ;
: stub ( -- )
create 0 lasttok +table ! ;
: :
create ] here bound to 4ed3 w,
locals off loops off nesting off !csp ;
: ;
?csp locals loops + ?dup
if compile <;lp> c, else compile <;> then
state off locals
if locals location c! then locals off loops off ;
immediate
code scanfor ( delimiter -- | sets in, str, len )
sp )+ d0 move, i' in a0 move, i' limit d1 move, ( get values )
d4 sp -) move, ( save d4 )
d1 d3 move, a0 d3 sub,
d3 swap, d3 d4 .w move, d3 swap,
begin,
begin, a0 )+ d2 .b move, pl
if, d0 d2 .b cmp,
else, d2 .b clr, then,
d3 ne -until,
d4 ne -until,
a0 d1 cmp, cs
if, d1 i' in move, d1 i' str move, 0 #n d1 moveq, d1 i' len move, then,
0 #n d2 moveq, a0 a1 move, 1 #n a1 subq,
begin,
begin, a0 )+ d2 .b move,
pl if, d0 d2 .b cmp, then,
d3 eq -until,
d4 eq -until,
a0 d0 move, a0 d1 cmp, cs
if, d1 a0 move, d1 d0 move,
else, 1 #n d0 subq, then,
a1 i' str move, a1 d0 sub, d0 i' len move,
a0 i' in move, sp )+ d4 move, next; ( restore d4 )
: "
ascii " scanfor -1 len +to 1 str +to state nesting or
if compile <"> len c, here len allot ( allot first )
str swap len cmove ( then emplace string, its safer )
else str len
then ;
immediate
: ascii
word str c@ state nesting or
if ( compiling) [compile] literal then ;
immediate
: +bit7 ( ch -> ch' | Set bit 7 in ch )
ff and 80 or ;
: check ( a l -> | Given name, print character string values )
dup 1 30 inrange
if 0
do dup i + c@ . loop drop
else 2drop ." empty string "
then ;
: ctl ( -> | Turns downstream character into control character value )
word str c@ 1f and ( make a control char out of it )
state nesting or
if [compile] literal then ; ( compiling )
: -trailing ( a c -> a c' | Adjust c to eliminate any trailing blanks )
dup 0 >
if dup 0
do 2dup + 1- c@ 20 <>
if leave else 1-
then loop then ;
: ( ( -> | skips characters until a right paren character is found )
ascii ) scanfor ;
immediate
: ;s ( -- | skips to end of block or next real document break )
edde
if in begin nextpage #wr @ dup limit < while
dup prevchar c@ dup pb = swap ds = or until
limit min ( find next document )
else limit then in to ; ( else finish block )
: ."
[compile] " state nesting or
if compile then type ;
immediate
: abort"
[compile] " compile <abort"> ;
immediate
code <string> ( -> a l | Fetch address and length of executed string name. This
must be a two byte token)
ip d0 move, 4 #n d0 addq, ( compute address)
d0 sp -) move, ( stack the string address)
ip ) d0 move, ( get the length ) d0 sp -) move, ( stack it)
tc' <exit> jmp, ( exit immediately) ;c
: string ( a l -> | Create a string with downstream name, emplace chars )
create 4ed3 w, ( jump (a3) compile <string>
dup , ( compile the string length)
dup 1 and
if ( odd length) 1+ ( increase move size)
then here swap ( s d l) dup allot move ;
: <"to> ( a l a l -> a' l )
local dlen local daddr local slen local saddr
local offset dlen to daddr to slen to saddr to
daddr 6 - w@ ['] <string> <> abort" not a string variable"
daddr current exa here inrange
daddr strings origin inrange or not
abort" can't assign to string in closed vocabulary"
slen dlen - offset to offset froom? ( check for room)
daddr 4 - @ 1 and
if -1 offset +to then
offset 1 and
if 1 offset +to then
daddr dlen + dup dup offset + here rot -
daddr dlen + here 1+ offset move&adjust
saddr daddr dlen + here inrange
if offset saddr +to then
saddr daddr slen move slen daddr 4 - ! daddr slen ;
: "to ( a l a l -> | Store chs in named string )
<"to> 2drop ;
: becomes ( mkr ch ch ... ch -> | Create string w name, emplace chs)
local addr local length local nlength
word str len find
if execute else abort" can't find" then
length to addr to depth nlength to
sp@ depth 1- ?dup
if 0
do dup @ string: =
if i nlength to leave then
4 + loop
then drop addr nlength addr length <"to>
dup length to + 1- addr to length
if length 0
do addr i - c! loop
then depth if drop then ;
code <csize> ( a -> n | Given the code addr, report code size of a word )
sp ) d0 move, ( a0 = addr )
i' here sp ) move, d0 sp ) sub, ( sp = stored delta )
i' tokens d1 move, 1 #n d1 subq, ( d0 = counter )
begin, bp d2 move, d2 .b clr, d1 d2 add, ( bp = 0table )
d2 d2 .w add, d2 d2 .w add, ( d1 = +table )
d2 a1 move, a1 ) d3 move, ffffff #n d3 andi, ( d3 = exa )
d0 d3 sub, gt ( addr < exa? )
if, sp ) d3 cmp, lt ( yes, delta < stored? )
if, d3 sp ) move, ( store new delta )
then, then,
d1 nt -until, next;
: csize ( -> n | Report the size of the downstream word's code)
c' <csize> ;
: retop ( a -> | move upper half of dictionary, new top at a )
local delta dup top - delta to ( save delta)
dup 1 and abort" top must be even" delta 0<
if drop delta negate applic here - > 0= outofroom
else text swap < text and ( if moving up, see if pushing into text )
if delta needtext outofroom ( and see if enough room in text )
delta isize 2dup mod - + text + endtext move&adjusttext then
then here ( save here. Now it is ok to move upper dictionary )
applic applic delta + top applic - ( move arguments )
applic top 1+ delta ( adjustment arguments )
move&adjust here to ; ( restore here)
( Note, retoping dosen't change here. However, if one should retop so that
applic lands on top of here then any subsequent retop will adjust here along
with applic. The simple fix to that is to always save and restore here.)
: setcodesize ( -> | Set open vocab's code size into itself, set odd flag )
here current exa 0a + - ( calculate code size )
dup applic @ + ( total size - 4 )
1 and ( is total odd? )
dup allot ( adjust here )
dup current exa 3 + c! + ( set flag, adjust code size )
current exa 6 + ! ; ( set code size )
: oddadjust ( -> | Adjust here by 0 or -1 depending on the odd flag)
current exa 3 + c@ 0 <> allot ;
: packforth ( -> | Make forth as small as possible, disable compiling )
setcodesize ( pack, a nontrivial retop operation )
top applic here - - ( new packed top )
retop
current on ( -1 signals allot 'dictionary packed' )
here on applic on ; ( meaningless when packed )
: unpackforth ( t addr -> | Move forth's top up to addr, set current to t )
over 0= abort" can't open forth"
over vopen ( place to open dictionary )
dup here to applic to ( setup for the retop operation )
retop ( move the top up )
current to ( new currently open vocabulary )
oddadjust ; ( if necessary )
: <addto> ( t -> | Close current and open vocabulary whose token is t )
dup current <> ( only if different from current )
if dup top ( save top )
packforth unpackforth then drop ;
: addto ( -> | Open the downstream vocabulary name for additions)
' dup vocab? not abort" not a vocabulary"
dup 0= abort" can't add to forth"
current 1 < abort" dictionary packed"
<addto> ; ( open it up for additions )
: invoc ( addr -- t | returns token of voc containing addr )
local addr addr to active extant ( extant's limit )
do i w@ ffff <>
while addr i w@ exa i w@ vopen dup @ + inrange
if i w@ exit then ( found voc, return token )
4 +loop -1 ; ( -1 = not contained in any vocab )
: deactivate ( -> | Remove the downstream vocabulary from the search order )
' <deactivate> ;
: <behead> ( a -> | Remove the header of the word name at a, close upward )
local hadd local hsiz local this
hadd to current this to
hadd [ romsize ] literal > ( don't behead in ROM )
if hadd invoc dup -1 = abort" head not in vocabulary"
<addto>
hadd 2+ c@ 1f and 3 + hsiz to ( save addr, size )
hsiz negate applic +! ( adjust vocabulary names size )
applic applic hsiz + hadd applic - ( move arguments )
applic hadd hsiz ( adjustment argumemts )
move&adjust
this <addto> then ;
: behead ( -> | Remove the downstream word's header, close upward )
n' <behead> ;
: <becode> ( a -> | Remove the code of the word whose token is t )
local cadd local csiz local this current this to
+table @ cadd to ( code execution address)
cadd [ romsize ] literal > ( do nothing if stubbed or in rom )
if cadd invoc <addto> ( open containing vocab )
cadd <csize> csiz to ( get & save the code size)
cadd csiz + cadd here cadd csiz + - ( move arguments)
cadd csiz + here 1+ csiz negate move&adjust ( adjust)
this <addto> then ; ( open original voc )
code <eta> ( voc.addr encoded-token --- 0 -or- eta )
sp )+ d0 move, sp ) a0 move, 0 #n d1 moveq,
d1 sp ) move, 6 ( 4+2) #n a0 addq, d0 d2 move, 8 #n d2 lsr,
begin, a0 )+ d1 .b move, 7f #n d1 .b cmp, eq if, next, then,
a0 )+ d0 .b cmp, eq
if, d1 d2 cmp, eq if, leave, then, then,
a0 )+ d1 .b move, 3f #n d1 .b and, d1 a0 add,
again, 2 #n a0 subq, a0 sp ) move, next;
: eta ( tk -> a t | From token, get encoded token address, true flag)
encode active extant do i w@ 7fff < ( done?)
while i w@ vopen over <eta> ?dup if nip -1 exit then
4 +loop drop 0 ( tk -> f | Can't find it, false flag) ;
: recycle ( token -- )
['] freetoken exa swap +table ! ;
: safety ( a -> | recycle the token of the word whose head is at a )
w@ decode recycle ;
: bevoc
' <bevoc> ;
: <purge> ( token -- )
dup <becode> dup recycle eta if <behead> then ;
: purge ( -> | Remove any word from any voc, including vocs )
' dup vocab? if <bevoc> else <purge> then ;
code emptyheadless ( start tokentablelo tokentablehigh -- )
sp )+ d1 move, sp )+ a0 move, sp )+ d0 move, i' here d3 move,
begin, a0 d1 cmp, nc
while, a0 )+ d2 move, d2 d0 cmp, cs
if, d2 d3 cmp, nc ( inrange? )
if, tc' freetoken #n a0 -4 )d move, ( yes, recycle )
then, then,
again, next;
: empty ( -- | empty the current vocabualry )
local start current ['] forth = abort" can't empty forth"
extant 10 0 do i 4 * over + dup 2+ w@ dup ffff =
if 2drop leave then current = ( no more vocabs, leave )
if dup w@ <bevoc> then drop loop drop ( remove subordinate vocabs )
current exa 0a + start to ( code addr of first def )
start 0 +table tokens +table
emptyheadless start here to ( recycle tokens, remove codespace )
0 here 4 - ! 0 here 7 - c! ( clear size count and oddbyte of code )
applic dup @ + 6 - applic to ( remove heads )
emptyvoc 0a + applic 0a move ; ( init heads )
: <empty> ( tok -- )
current >r <addto> empty r> <addto> ;
: <bevoc> ( token -- | completely eliminate vocabulary )
local this local parent local low local high local remover
this to ( save token )
this vocab? this ['] forth <> and ( vocab, but not forth? )
if current parent to ( save current vocab )
this <addto> empty ( delete all words in this vocab )
this <deactivate> ( delete from search order )
active extant
do this i w@ = ( find this voc in extant )
if i 2+ w@ ['] forth = abort" can't remove this vocabulary"
this parent =
if i 2+ w@ parent to then ( new parent? )
i remover to leave then
4 +loop
parent <addto> ( return to parent )
this eta if <behead> then ( remove name field )
this exa low to ( remove vocab structure )
this vopen dup @ + 4 + high to ( high = top of structure )
high here <
if low high here low - ( move args )
low here 1+ ( adj args )
else applic dup high low - + low applic - ( move args )
applic high 1+ ( adj args )
then high low - move&adjust ( s d c l u del -- )
remover 4 + remover ( extants limit )
active remover 4 + - move ( remove vocab from extant )
this recycle ( recycle token )
then ;
( NOTE: if createvoc is changed, change tvocabulary )
: createvoc ( addr token -- addr' | create an empty voc )
2dup +table ! >r ( update the vocab's token )
emptyvoc over 14 cmove ( copy image into place )
r> over 4 + w! 14 + ; ( place token in definition )
( NOTE: if vocabulary is changed, change tcreatevoc )
: vocabulary ( -> | Make new but inactive vocab whose name is in current )
active ( extant's limit )
4 - @ -1 <> abort" no vocs"
create ( create a name in current )
applic applic 14 - top applic - ( movement args )
applic top 1- -14 ( adjustment args )
move&adjust ( make room for new vestigial voc )
top 14 - lasttok createvoc drop ( create vocabulary )
extant dup 4 + active over - move ( make room in extant )
lasttok extant w! current extant 2+ w! ; ( new extant entry )
: name ( t -> | Print the name of a word given its token t )
eta if 2+ dup 1+ swap c@ 1f and space type then ;
: searched ( -> | Report the vocabulary search order, left to right )
[ .act #vocs 2* + ] literal active
do i w@ ffff = if leave then i w@ name 2 +loop space ;
: existing ( -> | Report the existing vocabularies and their parents)
0 active extant
do i w@ ffff = ( unused? )
if drop active i - 2/ 2/ leave then
i w@ name ." (in" i 2+ w@ name ascii ) emit space
4 +loop space . ." free " ;
: rub ( -> | do an erase-character function )
inct if -1 inct +to 8 emit then ;
: doit ( -> | Interpret the string)
tfont font to space itx inct interpret
state 0= if " ok" type then cr inct off panicked off
qfont font to ;
: <quit>
side0 ion von ( turn on the screen and keyboard again )
[ .exec ] literal execbuf to
savestate on ( so that :'s isolated ] enables compiling )
inct off state off locals off loops off nesting off
panicked off ( not currently panicked about anything )
str off len off ( not currently interpreting anything )
showmove? on ; ( so move&adjusttext will refresh the screen )
: quit ( -> | Reset nesting, etc. and begining interpreting again)
rp0 rp! <quit> qfont font to ( about to query) crt on edde off
begin
begin vticks@ 0=
if voff begin <?k> until von then ( so forth really offs screen )
?k until
key dup erase =
if drop rub
else dup 0d =
if drop doit
else dup 1f >
if dup emit itx inct + c!
1 inct +to inct 0a0 =
if doit then
else drop
then then then
again ;
: dump ( a c -> | Dump memory from a for c bytes )
base hex rot rot over + swap
do cr i 9 .r space
i 10 + i do i c@ <# # # #> space type loop space space
i pad 10 cmove pad 10 afilter pad 10 type
?keystep 0= while
10 +loop base to ;
: words ( -> | List the words in context vocabulary )
local out 50 out to active w@ vopen 6 +
begin dup w@ 7f7f u<
while 2+ dup 1+ swap c@ 1f and 2dup dup out + 4e >
if cr 0 out to ?keystep if 2drop drop leave then then
dup 1+ out +to type + space again drop ;
( String initializers are new -- 16Apr87/dab )
align here target - .$start to
t' initprint" .1st$tok to
( The following strings are imported from 'printersetup' to 'Print')
: initprint" <string> [ 0 ,
: userinit" <string> [ 0 ,
: leftfoot" <string> [ 0 ,
: rightfoot" <string> [ 0 ,
: leftfrill" <string> [ 2 , 2d c, 20 c,
: rightfrill" <string> [ 2 , 20 c, 2d c,
: topofform" <string> [ 0 ,
: endprint" <string> [ 0 ,
: endline" <string> [ 0 ,
: halfline" <string> [ 0 ,
: oldhalfline" <string> [ 0 ,
: startline" <string> [ 0 ,
: +underline" <string> [ 0 ,
: -underline" <string> [ 0 ,
: +bold" <string> [ 0 ,
: -bold" <string> [ 0 ,
: backspace" <string> [ 0 ,
: overstrike" <string> [ 0 ,
: unoverstrike" <string> [ 0 ,
: hmi" <string> [ 0 ,
: evenhalfspace" <string> [ 0 ,
: oddhalfspace" <string> [ 0 ,
: printreverse" <string> [ 0 ,
: printforward" <string> [ 0 ,
: modemdefault$ <string> [ 2 , ascii A c, ascii T c,
: modeminit$ <string> [ 2 , ascii A c, ascii T c,
: sendend$ <string> [ 2 , 0d c, 0a c,
: lastphone <string> [ 0 , ( last phone number dialed )
: answerback ( answerback string )
<string> [ " Canon Cat Modem" dup , ( set len)
here swap dup allot move ( and str)
: screensave$
<string> [ " Canon Cat" dup , ( set len)
here swap dup allot move ( and str)
( the learn strings for keys 0 through 9 )
: learn0 <string> [ 0 ,
: learn1 <string> [ 0 ,
: learn2 <string> [ 0 ,
: learn3 <string> [ 0 ,
: learn4 <string> [ 0 ,
: learn5 <string> [ 0 ,
: learn6 <string> [ 0 ,
: learn7 <string> [ 0 ,
: learn8 <string> [ 0 ,
: learn9 <string> [ 0 ,
align here target - .$end to
t' learn9 1+ .last$tok to
code learnstrings
nx ) jsr, ;c ( an array of learn strings )
t' learn0 w, t' learn1 w, t' learn2 w,
t' learn3 w, t' learn4 w, t' learn5 w,
t' learn6 w, t' learn7 w, t' learn8 w,
t' learn9 w,
( MT 6/1 )
code <chksumroms>
0 #n d6 moveq, ( Clear 1 HIGH Checksum )
0 #n d5 moveq, ( Clear 1 LOW Checksum )
0 #n d4 moveq, ( Clear 0 HIGH Checksum )
0 #n d3 moveq, ( Clear 0 LOW Checksum )
0 #n d1 moveq, ( Clear the temp storage register )
d3 a0 move, ( Get Starting Address )
10000 #n d0 move, ( Get count for the 0Low and 0High )
begin, a0 )+ d1 .b move, ( Get a byte of data )
d1 d4 add, ( Add to checksum )
a0 )+ d1 .b move, ( Get a byte of data )
d1 d3 add, ( Add to checksum )
1c #n opr .b move, ( reset watchdog timer )
1 #n d0 subq, eq ( Decrement the count )
until, ( Loop until done )
1FFF8 2/ #n d0 move, ( Set the count for ROM1 )
begin, a0 )+ d1 .b move, ( Get a byte of data )
d1 d6 add, ( Add to checksum )
a0 )+ d1 .b move, ( Get a byte of data )
d1 d5 add, ( Add to checksum )
1c #n opr .b move, ( reset watchdog timer )
1 #n d0 subq, eq ( Decrement the count )
until, a4 ) jmp, ( Return to caller )
;c
code chksumbyte ( addr len - even odd )
( Byte wide checksum for ROMs and the like )
sp ) d0 move, sp 4 )d a0 move,
1 #n d0 lsr, ( Divide count by two )
0 #n d2 moveq, ( Clear checksum for even )
0 #n d3 moveq, ( Clear checksum for odd )
0 #n d1 moveq, ( Clear temp storage )
begin, a0 )+ d1 .b move, ( Get a byte of data )
d1 d2 add, ( Add byte to checksum )
a0 )+ d1 .b move, ( Get second byte of data )
d1 d3 add, ( Add byte to checksum )
1 #n d0 subq, eq ( Decrement count )
until, d2 sp 4 )d move, d3 sp ) move, next;
code <svtest>
svram #n a0 move, ( Get start of SVRAM )
svramlen #n d1 move, ( Get count for loop )
0 #n d0 moveq, ( Set to clear SVRAM )
begin, d0 a0 ) .b move, ( Write zero's into SVRAM )
2 #n a0 addq, ( Increment to next address )
1 #n d1 subq, eq ( Loop until count = 0 )
until,
svram #n a0 move, ( Get start of SVRAM )
svramlen #n d1 move, ( Get length of SVRAM )
begin, a0 ) .b tst, ne ( Test byte to make sure it was 00 )
if, -1 #n d0 moveq, ( Set SV RAM ERROR )
a4 ) jmp, ( Return to caller )
then, a0 ) .b not, ( Toggle the byte )
2 #n a0 addq, ( Next address )
1 #n d1 subq, eq ( Decrement count )
until, svramlen #n d1 move, ( Get length of SVRAM )
begin, 2 #n a0 subq, ( Decrement Address )
a0 ) .b not, ne ( Toggle and test byte )
if, -1 #n d0 moveq, ( Set SV RAM ERROR )
a4 ) jmp, ( Return to caller )
then, 1 #n d1 subq, eq ( Decrement count )
until, svramlen #n d1 move, ( Get length of SVRAM )
-1 #n d0 moveq, ( Fill SVRAM with FF's )
begin, d0 a0 ) .b move, ( Write to SVRAM )
2 #n a0 addq, ( Increment the address )
1 #n d1 subq, eq ( Decrement the count )
until, svram #n a0 move, ( Get starting address )
svramlen #n d1 move, ( Get length of SVRAM )
begin, a0 ) .b not, ne ( Test and toggle byte )
if, -1 #n d0 moveq, ( Set SV RAM ERROR )
a4 ) jmp, ( Return to caller )
then, 2 #n a0 addq, ( Increment Address )
1 #n d1 subq, eq ( Decrement count )
until, svramlen #n d1 move, ( Get length of SVRAM )
begin, 2 #n a0 subq, ( Decrement address )
a0 ) .b tst, ne ( Test the byte )
if, -1 #n d0 moveq, ( Set SV RAM ERROR )
a4 ) jmp, ( Return to caller )
then, a0 ) .b not, ( Toggle the byte )
1 #n d1 subq, eq ( Decrement the count )
until, 0 #n d0 moveq, ( Set SV RAM OK )
a4 ) jmp, ;c ( Return to caller )
;s
here dup target - .memerr to " RAM Test Error"
dup allot 0 c, rot swap cmove
( <ramtest> Returns the error condition of the system RAM in D3 and D4 )
( D3 Bits 00-15 RAM 00-03 )
( D3 Bits 16-31 RAM 10-13 )
( D4 Bits 00-15 RAM 20-23 )
( D4 Bits 16-31 RAM 30-33 )
code <ramtest>
2700 #n sr .w move, ( Turn off interrupts )
0 #n d0 moveq, ( Set RAM to all 00's )
0 #n d3 moveq, ( Set RAM 00,01,02,03,10,11,12,13 OK )
0 #n d4 moveq, ( Set RAM 20,21,22,23,30,31,32,33 OK )
ramstart #n a0 move, ( Get the starting address of RAM )
ramsize 4 / #n d1 move, ( Get the count for the fill loop )
begin, d0 a0 )+ move, ( Write zeros to RAM )
1c #n opr .b move, ( reset watchdog timer )
1 #n d1 subq, eq ( Decrement count )
until, ( Loop until fill is done )
ramstart #n a0 move, ( Get the starting address of RAM )
ramsize 2/ #n d1 move, ( Get the word count )
-1 #n d2 moveq, ( Fill with FFFF's after testing )
begin, a0 ) d0 .w move, ne ( Read the RAM )
if, 460000 #n a0 cmp, ge ( Is it in RAM 30-33 )
if, d4 swap, d0 d4 .w or, ( Set Error )
d4 swap,
else, 440000 #n a0 cmp, ge ( Is it in RAM 20-23 )
if, d0 d4 .w or, ( Set Error )
else, 420000 #n a0 cmp, ge ( Is it in RAM 10-13 )
if, d3 swap, d0 d3 or, ( Set Error )
d3 swap,
else, d0 d3 or, ( Set Error )
then,
then,
then,
then, d2 a0 )+ .w move, ( Write FFFF's )
1c #n opr .b move, ( reset watchdog timer )
1 #n d1 subq, eq ( Decrement the count )
until, ( Loop until all of RAM is tested )
ramsize 2/ #n d1 move, ( Get the word count of RAM )
00 #n d2 moveq, ( Fill with 00's after test )
begin, a0 -) d0 .w move, ( Read the RAM )
-1 #n d0 .w cmpi, ne ( Was it FFFF )
if, d0 .w not,
460000 #n a0 cmp, ge ( Is it in RAM 30-33 )
if, d4 swap, d0 d4 .w or, ( Set Error )
d4 swap,
else, 440000 #n a0 cmp, ge ( Is it in RAM 20-23 )
if, d0 d4 .w or, ( Set Error )
else, 420000 #n a0 cmp, ge ( Is it in RAM 10-13 )
if, d3 swap, d0 d3 or, ( Set Error )
d3 swap,
else, d0 d3 or, ( Set Error )
then,
then,
then,
then, d2 a0 ) .w move, ( Write 0000's )
1c #n opr .b move, ( reset watchdog timer )
1 #n d1 .w subq, eq ( Decrement Count )
until, ( Loop until all of RAM is tested )
-1 #n d0 moveq, ( Set RAM to all FFFF's )
ramstart #n a0 move, ( Get the starting address of RAM )
ramsize 4 / #n d1 move, ( Get the count for the fill loop )
begin, d0 a0 )+ move, ( Write zeros to RAM )
1c #n opr .b move, ( reset watchdog timer )
1 #n d1 subq, eq ( Decrement count )
until, ( Loop until fill is done )
ramstart #n a0 move, ( Get the starting address of RAM )
ramsize 2/ #n d1 move, ( Get the word count )
00 #n d2 moveq, ( Fill with FFFF's after testing )
begin, a0 ) d0 .w move, ( Read the RAM )
-1 #n d0 .w cmpi, ne ( Was it FFFF )
if, d0 .w not,
460000 #n a0 cmp, ge ( Is it in RAM 30-33 )
if, d4 swap, d0 d4 .w or, ( Set Error )
d4 swap,
else, 440000 #n a0 cmp, ge ( Is it in RAM 20-23 )
if, d0 d4 .w or, ( Set Error )
else, 420000 #n a0 cmp, ge ( Is it in RAM 10-13 )
if, d3 swap, d0 d3 or, ( Set Error )
d3 swap,
else, d0 d3 or, ( Set Error )
then,
then,
then,
then, d2 a0 )+ .w move, ( Write FFFF's )
1c #n opr .b move, ( reset watchdog timer )
1 #n d1 subq, eq ( Decrement the count )
until, ( Loop until all of RAM is tested )
ramsize 2/ #n d1 move, ( Get the word count of RAM )
-1 #n d2 moveq, ( Fill with FFFF's after test )
begin, a0 -) d0 .w move, ne ( Read the RAM )
if, 460000 #n a0 cmp, ge ( Is it in RAM 30-33 )
if, d4 swap, d0 d4 .w or, ( Set Error )
d4 swap,
else, 440000 #n a0 cmp, ge ( Is it in RAM 20-23 )
if, d0 d4 .w or, ( Set Error )
else, 420000 #n a0 cmp, ge ( Is it in RAM 10-13 )
if, d3 swap, d0 d3 or, ( Set Error )
d3 swap,
else, d0 d3 or, ( Set Error )
then,
then,
then,
then, d2 a0 ) .w move, ( Write 0000's )
1c #n opr .b move, ( reset watchdog timer )
1 #n d1 .w subq, eq ( Decrement Count )
until, ( Loop until all of RAM is tested )
a4 ) jmp, ( Return to caller )
;c
( MT 6/1 )
( Returns the size of the system RAM in bytes in D0 )
code <ramsize>
a5a55a5a #n d3 move, ( Set pattern )
d3 d2 move, d2 not, ( Set invert of pattern )
0 #n d0 moveq, ( Set size to zero )
4 #n d1 moveq, ( Set number of banks to check )
ramstart 1FFFC + #n a0 move, ( Get first bank address )
begin, d3 a0 ) move, ( Write pattern )
a0 ) d3 cmp, eq ( Check pattern )
while, d2 a0 ) move, ( Write invert of pattern )
a0 ) d2 cmp, eq ( Check pattern )
while, 20000 #n a0 add, ( Goto next Bank )
20000 #n d0 add, ( Add one banks worth to size )
1 #n d1 .w subq, eq ( Checked all four banks? )
until, a4 ) jmp, ( Return to caller )
;c
code <<cold>> ( -> | Begin code to initialize forth, move rom tokens to ram)
( MT 6/2 )
0 :l ( entry for cold via 'tab-restart' key)
2700 #n sr .w move, ( make sure interrupts are off)
1c #n opr .b move, ( reset the watchdog first thing )
tc' reset.hardware jmp4, ( Reset all hardware )
screenend #n a0 move, ( Get address to start clearing from )
system.status.len system.diag - #n d0 .w move, ( Get count )
-1 #n d1 moveq, ( Fill with zeros )
begin, d1 a0 )+ .b move, ( Write with zeros )
1 #n d0 .w subq, eq
until,
00 #n ga3 kb.wr + .b move, ( Clear anything thats down )
09 #n ga3 pr.cont + .b move, ( Set to read country code )
8 #n d7 lsr, ( Delay )
8 #n d7 lsr, ( Delay )
ga3 kb.rd + d7 .b move, ( Get country code )
08 #n ga3 pr.cont + .b move, ( Clear country code read bit )
d7 .b tst, pl ( Test country code )
lif, tc' <chksumroms> jmp4, ( Get the ROM checksums )
d4 a6 move, ( Save a copy of 0 HIGH )
d3 a5 move, ( Save a copy of 0 LOW )
3FFF0 #n a0 move, ( Get address of ROM checksums )
a0 0 )d d0 movep, d0 neg, ( Get 0 HIGH checksum )
d4 d0 cmp, 2 ne bra, ( Exit if checksum doesn't match )
a0 1 )d d0 movep, d0 neg, ( Get 0 LOW checksum )
d3 d0 cmp, 2 ne bra, ( Exit if checksum doesn't match )
a0 8 )d d0 movep, d0 neg, ( Get 1 HIGH checksum )
d6 d0 cmp, 2 ne bra, ( Exit if checksum doesn't match )
a0 9 )d d0 movep, d0 neg, ( Get 1 LOW checksum )
d5 d0 cmp, 2 ne bra, ( Exit if checksum doesn't match )
33 #n duart ser.ctl + .b move, ( Set counter timer )
07 #n duart ser.cth + .b move, ( for 1Khz tone )
duart ser.cstart + d0 .b move, ( Start the timer )
04 #n duart ser.opcr + .b move, ( Turn on the output )
1c #n opr .b move, ( reset watchdog timer )
a85c #n d0 move, ( Set duration of tone to 500 ms )
begin, 8 #n d0 .w ror, ( Delay )
8 #n d0 .w ror, d0 nt ( Delay )
-until, ( Wait )
00 #n duart ser.opcr + .b move, ( Turn off the output )
2 :l 1c #n opr .b move, ( reset watchdog timer )
tc' <ramtest> jmp4, ( Execute system RAM test )
d3 .w tst, ne ( Is the low 128K working )
if, 99 #n duart ser.ctl + .b move, ( Set counter timer for 2Khz )
03 #n duart ser.cth + .b move, ( Set counter timer for 2Khz )
duart ser.cstart + d0 .b move, ( Start the timer )
04 #n duart ser.opcr + .b move, ( Turn on the output )
ramstart #n a0 move, ( Get starting RAM address )
begin, 1 #n a0 ) addq, 1c #n opr .b move, again, ( Twinkle & loop )
then,
screenend 4 + #n a0 move, ( Get the screen end address )
d3 a0 )+ move, ( Save the ramtest results )
d4 a0 )+ move, ( Save the ramtest results )
a6 a0 )+ move, ( Save 0HIGH checksum )
a5 a0 )+ move, ( Save 0LOW checksum )
0 #n d0 moveq, ( Clear )
romstart romsize + 8 - #n a1 move, ( Get address of the HIGH chksums )
a1 0 )d d0 .b move, d0 d6 add, ( Add chksum value to chksum )
a1 2 )d d0 .b move, d0 d6 add, ( Add chksum value to chksum )
a1 4 )d d0 .b move, d0 d6 add, ( Add chksum value to chksum )
a1 6 )d d0 .b move, d0 d6 add, ( Add chksum value to chksum )
d6 a0 )+ move, ( Save 1HIGH checksum )
a1 1 )d d0 .b move, d0 d5 add, ( Add chksum value to chksum )
a1 3 )d d0 .b move, d0 d5 add, ( Add chksum value to chksum )
a1 5 )d d0 .b move, d0 d5 add, ( Add chksum value to chksum )
a1 7 )d d0 .b move, d0 d5 add, ( Add chksum value to chksum )
d5 a0 )+ move, ( Save 1LOW checksum )
svram #n a0 move, ( Get start of the SVRAM )
svtemp #n a1 move, ( Get temp storage location of SVRAM )
svramlen 4 / 1- #n d0 .w move, ( Get count for move loop )
begin, a0 0 )d d1 movep, ( Read from SVRAM )
d1 a1 )+ move, ( Write to temp area )
8 #n a0 addq, ( Increment the SV address )
d0 nt ( Loop until count = -1 )
-until, 1c #n opr .b move, ( reset watchdog timer )
tc' <svtest> jmp4, ( Test the SVRAM )
screenend #n a0 move, ( Get the screen end address )
d0 a0 svtest.results system.diag - )d move, ( Save result of SV TEST )
svram #n a0 move, ( Get start of SVRAM )
svtemp #n a1 move, ( Get temp storage location of SVRAM )
svramlen 4 / 1- #n d0 .w move, ( Get count for move loop )
begin, a1 )+ d1 move, ( Get data from SVRAM temp storage )
d1 a0 0 )d movep, ( Write back data to SVRAM )
8 #n a0 addq, ( Increment the SV address )
d0 nt ( Loop until count = -1 )
-until,
then, tc' <ramsize> jmp4, ( Calculate the RAM size )
screenend #n a0 move, ( Get the screen end address )
d0 a0 ) move, ( Save the ramsize )
d7 a0 country.code system.diag - )d move, ( Save the country code )
.restart clr, ( make sure we don't getforward )
here target - restart.err ! ( entry point when err in restore )
.tb #n a1 move, ( ram base addr of 32 bit token table)
.romtbl #n a0 move, ( rom base addr of 16 bit token table)
#romtokens 1- ( this is the number of tokens to move)
#n d0 .w move, ( move 1024 -0 to 3ff- addresses to ram)
0 #n d1 moveq, ( clear d1 to zeros)
begin, 0 #n d1 moveq, ( clear d1 to zeros)
a0 )+ d1 .b move, ( pick up a 24 bit rom address)
8 #n d1 lsl, a0 )+ d1 .b move,
8 #n d1 lsl, a0 )+ d1 .b move,
d1 a1 )+ move, ( put it into the 32 bit wide)
d0 nt -until, ( ram token table)
( Done w/RAM token table load registers )
here 2+ .coldip to ( save target address of following #n field)
0 #n ip move, ( cold's initialize token address here)
1 :l ( entry point for warm start below)
sp0 #n sp move, ( a7 is parameter stack pointer )
sp usp move, ( user sp always points to parameter stack)
( ssp0 #n sp move, ( set interrupt stack ptr. )
rp0 #n rp move, ( a6 always points to return stack)
tromaddr' next target - ( ok now as it is next's ROM addr)
nx move, ( a4 always points to code for next)
.nest #n np move, ( a3 always points to code for nest)
.ramint #n vp move, ( a2 always points to code for integer)
.tbl #n bp move, ( d7 always points to ram token table)
here 2+ .curtok to ( set target address of #n parameter)
0 #n d4 move, ( ct, d4 points to zeroth nesting token tbl)
here 2+ .staddr to ( set target address of #n parameter)
0 #n d5 move, ( sa, d5 holds zeroth nesting start address)
next,
here target - .level7 to ( warm start, NMI, entrance address)
( code to save machine state in case this is snapshot)
sr .s/r 64 + .w move, ( save 68008 status register first)
(regs a0 a1 a2 a3 a4 a5 a6 a7 to) .s/r 00 + movem,
(regs d0 d1 d2 d3 d4 d5 d6 d7 to) .s/r 20 + movem,
i' system.status a0 move, ( get the system.status )
a0 ga2opr )d d0 .b move, ( get copy of opr )
8 #n d0 .b or, d0 opr .b move, ( reset the watchdog timer )
.s/r 42 + #n a1 move,
0c #n d0 moveq,
begin, a0 ) a1 )+ .b move, 10 #n a0 add, d0 nt -until,
3326 #n .s/r 66 + .w move, ( disk type)
4f #n .s/r 68 + .w move, ( # trks to snapshot)
18000 #n d0 .w move, 0 #n d1 moveq, d1 d2 move, d1 a0 move,
begin, a0 )+ d2 .b move, d2 d1 add, 1 #n d0 subq, eq until,
d1 .s/r 80 + move, ( compute and store rom checksum)
-1 #n .s/r 100 + move, ( a disk# of -1 means a user snapshot)
( sample keyboard - determine how the user wants to start up)
ff #n ga3 kb.wr + .b move, ( enable all keyboard cols )
8 #n d0 lsr, 7 #n d0 lsr, ( delay for 26+24 cycles=10 us )
0 #n d0 moveq, ga3 kb.rd + d0 .b move, ( read in all 8 rows )
00 #n ga3 kb.wr + .b move, ( disable keyboard cols again)
df #n d0 .b cmp, eq if, 0 bra, ( COLD START) then, ( tab key )
fd #n d0 .b cmp, eq if, -1 #n i' Forth? move, then, ( space bar )
here 2+ .warmip to ( save target address of #n parameter)
0 #n ip move, ( the address of token for abort here)
i' Forth? tst, ( see if the person is a programmer )
ne if, i' edde clr, then, ( if not programmer, return to whence you came )
i' system.status a0 move, ( or a super programmer )
a0 svspare )d .b tst, ne
if, i' edde clr, then,
1 bra, ;c ( jump into common part of cold)
( trace support code )
code tracenest ( do the : nesting. forth's next follows nest)
sa ip .w sub, ( make the delta ip)
ip rp -) .w move, ( save the delta ip)
ct rp -) .w move, ( save lover 16 bits of the token pointer)
a1 2 )d ip lea, ( load ip with code address)
a1 sa move, ( save ip)
a0 ct move, ;c ( save token pointer)
code tracenext
i' tracepointer ct cmp, eq ( is this token being traced? )
if, 0 #n i' toggletrace 3 + .b bset, ne
if, iv i' saveiv move,
.nest #n np move, ( restore original nest reg )
tromaddr' next @ #n nx move, ( restore original next reg )
t' displaytrace #n sp -) move,
tc' execute jmp, ( upper level trace )
else, i' saveiv iv move, ( so that to, +to, on, and off will work )
then, then, ip )+ bp .b move, ( 1 byte token to base reg, upper 3 preset )
bp a0 move, ( work register, all 4 bytes meaningful now )
a0 a0 .w add, a0 a0 .w add, ( low part *4 to get 32-bit addr )
a0 ) a1 move, ( code address )
a1 ) jmp, ;c ( execution begins)
0 ( floating entry address seed for stack security )
code tracetier1 ( phase one of code traceing; the timesaver triggers )
.tbl 100 + #n d0 move,
drop here target - ( entry from the other tiers )
ip )+ d0 .b move, i' codetoken 3 + d0 .b cmp, eq
if, -1 #n i' codetoken 2+ .b cmp, ne
if, d0 a0 move, a0 a0 .w add, a0 a0 .w add, a0 ) a1 move,
8000 #n sr .w or, a1 ) jmp, ( turn trace bit on )
then, then, d0 a0 move, a0 a0 .w add, a0 a0 .w add,
a0 ) a1 move, a1 ) jmp, ;c
code tracetier2 .tbl 200 + #n d0 move, dup jmp, ;c ( into tier1 )
code tracetier3 .tbl 300 + #n d0 move, dup jmp, ;c ( " )
code tracetier4 .tbl 400 + #n d0 move, dup jmp, ;c
code tracetier5 .tbl 500 + #n d0 move, dup jmp, ;c
code tracetier6 .tbl 600 + #n d0 move, dup jmp, ;c
code tracetier7 .tbl 700 + #n d0 move, dup jmp, ;c ( " )
code tracetier8 .tbl 800 + #n d0 move, dup jmp, ;c
code tracetier9 .tbl 900 + #n d0 move, dup jmp, ;c
code tracetiera .tbl a00 + #n d0 move, dup jmp, ;c
code tracetierb .tbl b00 + #n d0 move, dup jmp, ;c
code tracetierc .tbl c00 + #n d0 move, dup jmp, ;c
code tracetierd .tbl d00 + #n d0 move, dup jmp, ;c
code tracetiere .tbl e00 + #n d0 move, dup jmp, ;c
code tracetierf .tbl f00 + #n d0 move, dup jmp, ;c drop
code triggernest ( do the : nesting. forth's next follows nest )
sa ip .w sub, ( make the delta ip)
ip rp -) .w move, ( save the delta ip)
ct rp -) .w move, ( save lover 16 bits of the token pointer)
a1 2 )d ip lea, ( load ip with code address)
a1 sa move, ( save ip)
a0 ct move, ;c ( save token pointer)
code triggernext ( trigger version of next )
ip )+ d0 .b move, ( d0= high [or only] byte of token )
d0 bp .b move, ( 1 byte tok to base reg, hi 3 preset )
bp a0 move, ( work reg, all 4 bytes used )
a0 a0 .w add, a0 a0 .w add, ( low part *4 to get 32-bit addr )
a0 ) a1 move, ( code address )
i' codetoken 3 + d0 .b cmp, ne ( token matches low byte? )
if, 1 :l -1 #n i' codetoken cmp, eq ( codetrace sets codetoken= -1 )
if, ct i' tracepointer move, ( ascend tracing to calling )
1 #n ip subq, ( ugh! unfetch next instruct'n )
-2 #n i' codetoken move, ( "disposable" exit )
tc' tracenext jmp, then, ( through tracenext )
else, i' codetoken 2+ .b tst, 1 ne bra, ( yes, high byte = 0? )
8000 #n sr .w or, ( yes, turn on trace bit )
then, a1 ) jmp, ;c
code traceoff ( -- | turn trace off )
tromaddr' next @ #n nx move,
.nest #n np move, next;
code codetrace ( -- | phase two )
tc' triggernext #n sp 2 )d cmp, nc
if, tc' traceoff 6 - #n sp 2 )d cmp, cs ( is this triggernext code? )
if, 7f #n sp ) .b and, ( yes, clr "T" bit in sr copy )
i' traceiling tst, ne ( is trace ceiling set to 0? )
if, tc' tracenest #n np move, ( no, install trace next )
tc' tracenext #n nx move,
-1 #n i' toggletrace move, ( so will display first word )
0 #n i' ctrace move, ( low level trace off )
-1 #n i' codetoken move, ( = triggernext call tracenext )
else, tromaddr' next @ #n nx move, ( trace ceiling is set to zero )
.nest #n np move, ( install normal next )
then, rte, ( this is triggernext, return )
then, then, ( this isn't, display )
sp )+ i' savesr .w move, 0 #n i' savesr 2+ .w move,
sp )+ i' saveip move,
(regs d0 d1 d2 d3 d4 d5 d6 d7 a0 a1 a2 a3 a4 a5 a6 a7 to) saveregs movem,
(regs d0 d1 d2 d3 d4 d5 d6 d7 a0 a1 a2 a3 a4 a5 from) uraniumregs movem,
t' displaycodetrace #n sp -) move, ( display trace info )
tc' execute jmp, ;c
( High level diagnostics )
: invert-screen
ga2opr@ 10 xor ga2opr! ;
: normal-screen
ga2opr@ 10 or ga2opr! ;
code $>lbuff ( addr len -- )
sp )+ d0 move, sp )+ a0 move, d0 d1 move, 54 #n d3 moveq,
i' lbuff a1 move, 1 #n d1 subq,
begin, 1 #n d3 .w subq, 0 #n d2 moveq, a0 )+ d2 .b move, 8 #n d2 ror,
d2 a1 )+ move, d1 nt
-until,
begin, 1 #n d3 .w subq, ne
while, 20000000 #n a1 )+ move, ( Fill to end of buffer with spaces )
again,
stopbit #n a1 -3 )d .b bset, next;
code char>lbuff ( char atrib pos -- )
sp )+ d2 move, sp )+ d1 move, sp )+ d0 move,
i' lbuff a0 move, 2 #n d2 lsl, d2 a0 add,
d0 a0 )+ .b move, d1 a0 )+ .b move, next;
code $>char ( addr len atrib pos -- )
( places the string into lbuff at pos setting the atributes to atrib )
sp )+ d2 move, sp )+ d1 move, sp )+ d0 move, sp )+ a0 move,
i' lbuff a1 move, 2 #n d2 lsl, d2 a1 add, 1 #n d0 subq,
begin, a0 )+ a1 )+ .b move, d1 a1 )+ .b move, ( move char and attrib to lbuff)
&firstacc #n a0 ) .b cmp, ( if next char is an accent )
ge if, &lastacc #n a0 ) .b cmp,
le if, 0 #n a1 )+ .b move, a0 )+ a1 )+ .b move, ( put in lbuff )
d0 .w tst, eq if, leave, then, ( see if done )
1 #n d0 .w subq, ( if not, subtract extra char )
else, 2 #n a1 add, then, ( if not accent, advance lbuff )
else, 2 #n a1 add, then,
d0 nt -until, next; ( until done )
: #>lbuff ( number atrib pos -- ) ( Places the number into lbuff )
local pos local atrib pos to atrib to
dup abs <# #s sign #> atrib pos $>char ;
: #>lbuff8 ( number atrib pos -- )
local pos local atrib pos to atrib to
<# # # # # # # # # #> atrib pos $>char ;
code blank-lbuff
53 #n d1 .w move, i' lbuff a0 move,
begin, 20000000 #n a0 )+ move, d1 nt
-until, stopbit #n a0 -3 )d .b bset, next;
code inverse-line
i' lbuff a0 move, 1 #n a0 add, 53 #n d1 .w move,
begin, invbit #n a0 ) .b bset, 4 #n a0 add, d1 nt
-until, next;
code bold-line
i' lbuff a0 move, 1 #n a0 add, 53 #n d1 .w move,
begin, boldbit #n a0 ) .b bset, 4 #n a0 add, d1 nt
-until, next;
code invert.chars
i' lbuff a0 move, sp )+ d0 move, ne
if, sp )+ d1 move, 2 #n d1 lsl, 1 #n d1 addq, d1 a0 add,
begin, invbit #n a0 ) .b bset, 4 #n a0 addq, 1 #n d0 subq, eq
until,
else, 4 #n sp addq,
then, next;
( Crt Adjustment )
: !H 1e000000 swap ! ;
: !# 1f000000 swap ! ;
code hline ( n -- | draws a line on line n MT 4/6/87)
sp )+ d0 move, ramstart #n a0 move,
/scan #n d0 .w mulu,
d0 a0 add, /lscan 4 / 1- #n d0 .w move, 0 #n d1 moveq,
begin, d1 a0 )+ move, d0 nt
-until, next;
code vline ( n -- | draws a vertical line on line n MT 4/7/87)
sp )+ d0 move, ramstart #n a0 move,
d0 d1 move, d1 not, 3 #n d0 lsr, d0 a0 add,
height 2- #n d0 .w move,
begin, d1 a0 ) .b bclr, /scan #n a0 add, d0 nt
-until, next;
: stop $end swap 1 + or! ;
: .line ( MT 4/10/87 )
54 0
do i over + 120 mod 90 /mod
if 20 + 8 shl [ $bold ] literal or 10 shl
else 20 + 18 shl
then i 4 * lbuff + !
loop drop [ $end ] literal lbuff 14D + or! ;
: pat1 cls 54 0
do i 4 * lbuff + !H
loop lbuff 14c + stop 18 0
do i 2* disp loop ;
: pat2odd 54 0
do i 4 * lbuff + !H i 1+ 4 * lbuff + !# 2 +loop lbuff 14c + stop ;
: pat2even 54 0
do i 4 * lbuff + !# i 1+ 4 * lbuff + !H 2 +loop lbuff 14c + stop ;
: pat2 cls pat2odd 18 0
do i 2* disp 2 +loop pat2even 18 0
do i 1+ 2* disp 2 +loop ;
decimal
: pat3 cls
0 hline 0 vline
31 hline 41 vline
62 hline 82 vline
93 hline 123 vline
124 hline 164 vline
155 hline 205 vline
188 hline 246 vline
219 hline 287 vline
250 hline 328 vline
281 hline 343 vline
312 hline 384 vline
343 hline 425 vline
466 vline 507 vline
548 vline 589 vline
630 vline 671 vline
335 171 1 <point>
336 171 1 <point>
335 172 1 <point>
336 172 1 <point> ;
hex
: pat4
[ ramstart ] literal [ screenstart bytes/line 0C * + ] literal over - FF fill
[ screenstart bytes/line 0C * + ] literal [ screenend ] literal over - 00 fill
local firstchar firstchar off ramstart screenstart over -
begin
0C 0 do i 54 * firstchar + .line i 2* disp ?k
if key dup 20 =
if exit
else dup 0D =
if exit
else dup e1 =
if invert-screen
then
then
then drop
then loop
0C 0 do i 54 * firstchar + .line inverse-line i 0C + 2* disp ?k
if key dup 20 =
if exit
else dup 0D =
if exit
else dup e1 =
if invert-screen
then
then
then drop
then loop
1 firstchar +to
again ;
: crt-test ( MT 4/10/87 )
local test 0 test to cls pat1
begin key dup d = not
while dup 20 =
if normal-screen drop
begin test 1+ 5 mod test to test 0 =
if pat1 -1
else test 1 =
if pat2 -1
else test 2 =
if pat3 -1
else test 3 =
if pat4 0D =
if normal-screen exit
then 0
else cls -1
then
then
then
then
until
else E1 =
if invert-screen
then
then
again normal-screen drop ;
( Disk Calabration Words )
: diskadj-keywait
begin don if -1 exit then ?k until key ;
: test1
dm1 bold-line C disp
begin recal
if beep dm1 C disp E1 exit
then 28 seek
if beep dm1 C disp E1 exit
then
begin diskadj-keywait dup E1 = over 0D = or over dup 30 > swap 37 < and or
if dm1 C disp exit
then beep
again
again ;
: test2
dm2 bold-line E disp
begin 27 seek
if beep dm2 E disp E1 exit
then 28 seek
if beep dm2 E disp E1 exit
then
begin diskadj-keywait dup E1 = over 0D = or over dup 30 > swap 37 < and or
if dm2 E disp exit
then beep
again
again ;
: test3
dm3 bold-line 10 disp
begin 29 seek
if beep dm3 10 disp E1 exit
then 28 seek
if beep dm3 10 disp E1 exit
then
begin diskadj-keywait dup E1 = over 0D = or over dup 30 > swap 37 < and or
if dm3 10 disp exit
then beep
again
again ;
: test4
dm4 bold-line 18 disp
begin c ms 6 seek 0=
while c ms 0 seek 0=
while ?k
if key dup E1 = over 0D = or over dup 30 > swap 37 < and or
if dm4 18 disp exit
then beep
then
again beep dm4 18 disp E1 ;
: test5
dm5 bold-line 1A disp
begin recal
if beep dm5 1A disp E1 exit
then ?wprot
if beep dm5 1A disp E1 exit
then <write55>
begin diskadj-keywait dup E1 = over 0D = or over dup 30 > swap 37 < and or
if dm5 1A disp exit
then beep
again
again ;
: test6
dm6 bold-line 1C disp
begin recal
if beep dm6 1C disp E1 exit
then 4F seek
if beep dm6 1C disp E1 exit
then ?wprot
if beep dm6 1C disp E1 exit
then <write55>
begin diskadj-keywait dup E1 = over 0D = or over dup 30 > swap 37 < and or
if dm6 1C disp exit
then beep
again
again ;
: dm1 " [1] Index Burst Position" $>lbuff ;
: dm2 " [2] Step In" $>lbuff ;
: dm3 " [3] Step Out" $>lbuff ;
: dm4 " [4] Track 00" $>lbuff ;
: dm5 " [5] Track 00 Modulation" $>lbuff ;
: dm6 " [6] Track 79 Modulation" $>lbuff ;
: diskadj-menu cls
" FDD Adjustment" $>lbuff 8 disp
" Insert Alignment Disk and select [1][2][3] to start when ready."
$>lbuff 8 disp
dm1 c disp
dm2 e disp
dm3 10 disp
" Insert Normal Disk and select [4][5][6] to start when ready."
$>lbuff 14 disp
dm4 18 disp
dm5 1A disp
dm6 1C disp
" Press [UNDO] to quit" $>lbuff 20 disp
" Press [RETURN] to return to check menu" $>lbuff 22 disp ;
: disk-adjust ( MT 4/14/87 )
local curkey
doff diskadj-menu
begin
begin key dup curkey to dup 0D = over E1 = or swap dup 30 > swap 37 < and or
until
begin curkey 31 =
if test1 curkey to
then curkey 32 =
if test2 curkey to
then curkey 33 =
if test3 curkey to
then curkey 34 =
if test4 curkey to
then curkey 35 =
if test5 curkey to
then curkey 36 =
if test6 curkey to
then curkey E1 =
if doff
then curkey dup 30 > swap 37 < and 0=
until curkey 0D =
until recal if beep then doff ;
( Disk Test Words )
code fill-disktest ( Addr Len -- )
sp )+ d0 move, sp )+ a0 move,
begin, DB #n a0 )+ .b move, 1 #n d0 subq, ne
while, 6D #n a0 )+ .b move, 1 #n d0 subq, ne
while, B6 #n a0 )+ .b move, 1 #n d0 subq, eq
until, next;
: testline
" Sequence= Retry Count= Recalibrate Count= Wr/Rd Mode= "
$>lbuff ;
: .stepin ( type -- | Places "Step In" in lbuff and inverses it if type <> 0)
local type type off
if 01 type to
then
" Step In" type B $>char ;
: .stepin/out
local type type off
if 01 type to
then
" Step In/Out" type B $>char ;
: .fixed
local type type off
if 01 type to
then
" Fixed" type B $>char ;
: .wr
local type type off
if 01 type to
then
" WR" type 48 $>char ;
: .rd
local type type off
if 01 type to
then " RD" type 48 $>char ;
: .rw rw if .wr else .rd then ;
: .retry
local type type off
if 01 type to
then #retry 30 + type 24 char>lbuff ;
: .recal
local type type off
if 01 type to
then #recal 30 + type 39 char>lbuff ;
: .curtest ( type -- | prints cur test type )
dtest# 1 =
if .stepin
else dtest# 2 =
if .stepin/out
else dtest# 3 =
if .fixed
then
then
then ;
: field0-msg
" [1]=Step In [2]=Step In/Out [3]=Fixed" $>lbuff ;
: field1-msg
" Number of times to recalibrate before reporting error. [0-9]" $>lbuff ;
: field2-msg
" Number of times to retry sector before recalibrating. [0-9]" $>lbuff ;
: field3-msg
" [R]=Read Only Check [W]=Write Before Read Check" $>lbuff ;
: field4-msg
" Track Number to check. [0-79]" $>lbuff ;
: field5-msg
" Sector Number to check. [0-9]" $>lbuff ;
: fixed-data
" Track= Sector=" $>lbuff ;
: .trk#
local type type off
if 01 type to
then trk# 0a /mod 30 + type 9 char>lbuff 30 + type 0a char>lbuff ;
: .sect#
local type type off
if 01 type to
then sect# 30 + type 15 char>lbuff ;
: .field-info
field 0 =
if field0-msg
else field 1 =
if field1-msg
else field 2 =
if field2-msg
else field 3 =
if field3-msg
else field 4 =
if field4-msg
else field 5 =
if field5-msg
else blank-lbuff
then
then
then
then
then
then 28 disp ;
: .status
.field-info
testline
0 field = .curtest
1 field = .retry
2 field = .recal
3 field = .rw 2 disp
dtest# 3 =
if fixed-data field 4 = .trk# field 5 = .sect#
else blank-lbuff
then 4 disp ;
: disktest-menu cls
" FDD Check:" $>lbuff 0 disp
testline 0 .curtest 0 .retry 0 .recal 0 .rw 2 disp
" Press [SPACE] to start." $>lbuff 2a disp
" Press [RETURN] to return to check menu." $>lbuff 2c disp ;
: ?number dup 2f > swap 3a < and ;
: update-field0
local curkey curkey to
curkey 30 > curkey 34 < and
if curkey 30 - dtest# to
else beep
then ;
: update-field1
local curkey curkey to
curkey ?number
if curkey 30 - #retry to
else beep
then ;
: update-field2
local curkey curkey to
curkey ?number
if curkey 30 - #recal to
else beep
then ;
: update-field3
local curkey curkey to
curkey 72 =
if rw off
else curkey 77 =
if rw on
else beep
then
then ;
: update-field4
local curkey curkey to
curkey ?number
if curkey 30 - trk# 0a mod 0a * + dup 4f >
if 0a mod
then trk# to
else beep
then ;
: update-field5
local curkey curkey to
curkey ?number
if curkey 30 - sect# to
else beep
then ;
: update-field
field 0 =
if update-field0
else field 1 =
if update-field1
else field 2 =
if update-field2
else field 3 =
if update-field3
else field 4 =
if update-field4
else field 5 =
if update-field5
else drop
then
then
then
then
then
then ;
: +field
dtest# 3 =
if 6
else 4
then field 1+ swap mod field to ;
: -field
field 1- dup 0<
if dtest# 3 =
if drop 5
else drop 3
then
then field to ;
: dtest-status-msg
" Pass: Track: Sector: Error: Type:" $>lbuff ;
: .dtest-status
dtest-status-msg
dpass 0 0a #>lbuff
trk# 0 16 #>lbuff
sect# 0 23 #>lbuff
diskerr dup 0 2f #>lbuff
dup 1 =
if " Drive Not Ready"
else dup 2 =
if " Seek Error"
else dup 3 =
if " Write Protected"
else dup 4 =
if " No Valid Headers"
else dup 5 =
if " Header CRC Error"
else dup 6 =
if " No Valid Data Field"
else dup 7 =
if " Data Field CRC Error"
else dup 8 =
if " Verify Error"
else dup 9 =
if " Wrong Headers Found"
else " Unspecified"
then
then
then
then
then
then
then
then
then 0 3C $>char drop 26 disp ;
: .dpass
" Pass:" $>lbuff dpass 0 0a #>lbuff 26 disp ;
: scroll-dtest-window
[ screenstart bytes/line 4 * + ] literal
[ screenstart bytes/line 3 * + ] literal
[ bytes/line 11 * ] literal move ;
: cls-dtest
[ screenstart bytes/line 3 * + ] literal
[ bytes/line 11 * ] literal -1 fill ;
: .diskerr
ff and ff xor 1+ diskerr to beep .dtest-status scroll-dtest-window .dpass ;
: fixed-test ( MT 4/14/87 )
trk# [ sectors ] literal * sect# +
trkbuf 200 fill-disktest
begin 1 dpass +to .dpass rw
if rd/wr on trkbuf over wsector ?dup
if .diskerr
then ?k
if key E1 =
if drop exit
then
then
then rd/wr off trkbuf over rw
if vsector
else rsector
then ?dup
if .diskerr
then ?k
if key E1 =
if drop exit
then
then
again ;
: stepin-test ( MT 4/14/87 )
trkbuf 1400 fill-disktest ( Set up trkbuf for rw data )
begin 1 dpass +to .dpass rw
if rd/wr on [ tracks ] literal 0
do i dup trk# to trkbuf swap wtrk ?dup
if sect# off .diskerr
then ?k
if key E1 =
if exit
then
then
loop
then rd/wr off [ tracks ] literal 0
do i dup trk# to trkbuf swap rw
if vtrk
else rtrk
then
if 0a 0
do i dup sect# to
system.status [ track.err ] literal + + c@ ?dup
if .diskerr
then
loop
then ?k
if key E1 =
if exit
then
then
loop
again ;
: stepin/out-test ( MT 4/14/87 )
trkbuf 200 fill-disktest ( Set up trkbuf for rw data )
begin 1 dpass +to .dpass rw
if rd/wr on [ tracks 2/ ] literal 0
do i trk# to trkbuf i wtrk ?dup
if sect# off .diskerr
then ?k
if key E1 =
if exit
then
then i [ tracks 2/ ] literal + dup trk# to trkbuf swap wtrk ?dup
if .diskerr
then ?k
if key E1 =
if exit
then
then
loop
then rd/wr off [ tracks 2/ ] literal 0
do i dup trk# to trkbuf swap rw
if vtrk
else rtrk
then ?dup
if 0a 0
do i dup sect# to
system.status [ track.err ] literal + + c@ ?dup
if .diskerr
then
loop
then ?k
if key E1 =
if exit
then
then [ tracks 2/ ] literal i + dup trk# to trkbuf swap rw
if vtrk
else rtrk
then
if 0a 0
do i dup sect# to
system.status [ track.err ] literal + + c@ ?dup
if .diskerr
then
loop
then ?k
if key E1 =
if exit
then
then
loop
again ;
: start-test
cls-dtest
" Press [UNDO] to quit current disk check." $>lbuff 2c disp
0 dpass to dtest# 1 =
if stepin-test
else dtest# 2 =
if stepin/out-test
else dtest# 3 =
if fixed-test
then
then
then ;
: disktest
local curkey base 0A base to
disktest-menu .status
begin " Press [RETURN] to return to check menu." $>lbuff 2c disp
begin <key> ff and dup curkey to 80 <
until curkey d = not
while 7 curkey =
if +field
else 6 curkey =
if -field
else 20 curkey =
if start-test
else curkey update-field
then
then
then .status
again base to ;
: <disk-clean>
don 0=
if recal 0=
if [ tracks ] literal 0
do i seek
if beep exit
then ( 1E ms )
loop [ tracks ] literal 0
do [ tracks 1- ] literal i - seek
if beep exit
then ( 1E ms )
loop
else beep
then
else beep
then ;
: disk-clean
cls
" Insert Cleaning Disk and press [SPACE] when ready." $>lbuff
10 disp
" Press [RETURN] to return to check menu." $>lbuff 12 disp
begin key dup 20 =
if <disk-clean> drop doff exit
then 0D =
if exit
then beep
until ;
( Keyboard Test )
( key number table USA )
( first byte = length )
( second byte = position in lbuff )
( third byte = row number )
( fourth byte = scancode number )
here target - .keynumbers to
01060138 , 010A0128 , 010E0120 , 01120110 ,
01160108 , 011A0100 , 011E0101 , 01220109 ,
01260111 , 012A0119 , 012E0121 , 01320129 ,
01360131 , 093A0139 , ( Row 1 )
03060232 , 010C022A , 01100222 , 0114021A ,
0118020A , 011C0202 , 01200203 , 0124020B ,
01280213 , 012C021B , 01300223 , 0134022B ,
01380233 , 073C023B , ( Row 2 )
0406033C , 010D0334 , 0111032C , 01150324 ,
0119031C , 011D0314 , 0121030C , 01250304 ,
01290305 , 012D030D , 01310315 , 0135031D ,
01390325 , 063D032D , ( Row 3 )
0206043F , 010B0437 , 010F042F , 01130427 ,
0117041F , 011B0417 , 011F040F , 01230407 ,
01270406 , 012B040E , 012F0416 , 01330435 ,
0537043F , ( Row 4 )
090B051E , 0F17052E , 09290526 , 0435053D , ( Row 5 )
06180636 , 0621063E , ( Row 6 )
( Keys are numbered 0 to 3b starting from the upper left to the )
( lower right )
code @keyscan ( key# -- scancode )
sp ) d0 move, .keynumbers 3 + #n a0 move,
2 #n d0 lsl, d0 a0 add, 0 #n d0 moveq, a0 ) d0 .b move,
d0 sp ) move, next;
code @keypos ( key# -- position )
sp ) d0 move, 2 #n d0 lsl,
.keynumbers #n a0 move, d0 a0 add, 0 #n d1 moveq,
a0 1 )d d1 .b move, d1 sp ) move, next;
code @keyrow ( key# -- row )
sp ) d0 move, 2 #n d0 lsl,
.keynumbers #n a0 move, d0 a0 add, 0 #n d1 moveq,
a0 2 )d d1 .b move, d1 sp ) move, next;
: clr-keytest
trkbuf 8 0 fill ;
code ?keytest
sp ) d0 move, d0 d1 move, 3 #n d1 lsr, 7 #n d0 and,
i' trkbuf a0 move, d1 a0 add, d0 a0 ) .b btst, eq
if, sp ) clr,
else, -1 #n sp ) move,
then, next;
code setkey
sp )+ d0 move, d0 d1 move, 3 #n d1 lsr, 7 #n d0 and,
i' trkbuf a0 move, d1 a0 add, d0 a0 ) .b bset, next;
: $undo " UNDO " ;
: $tab " TAB" ;
: $erase " ERASE " ;
: $lock " LOCK" ;
: $return " RETURN" ;
: $sh " SH" ;
: $shift " SHIFT" ;
: $use-front " USE FRONT" ;
: $space-bar " SPACE BAR " ;
: $lleap " <-LEAP" ;
: $rleap " LEAP->" ;
: $page " PAGE" ;
code key$
sp )+ a1 move, sp ) d0 move, 2 #n d0 lsl,
.keynumbers #n a0 move, d0 a0 add,
0 #n d0 moveq, a0 3 )d d0 .b move,
1 #n d0 lsl, d0 a1 add,
a1 ) d0 .w move, eq
if, 20 #n d0 moveq, 0 #n d2 moveq,
else, 1 #n d2 moveq,
then, d0 sp ) move, d2 sp -) move, next;
: @key$
local curkey curkey to
curkey 0D =
if $undo else curkey 0E =
if $tab else curkey 1B =
if $erase else curkey 1C =
if $lock else curkey 29 =
if $return else curkey 2A =
if $sh else curkey 36 =
if $shift else curkey 37 = curkey 39 = or
if $use-front else curkey 38 =
if $space-bar else curkey 3B =
if $lleap else curkey 3C =
if $rleap else curkey 3A =
if $page else curkey system.status [ country.code ] literal +
@ ff xor 7f and 200 * <kcodes> + key$ ?dup 0=
if curkey setkey 1
then then then then then then then then then then then then then ;
code !doublechar
sp )+ d0 move, sp )+ d1 move, sp )+ d2 move,
i' lbuff a0 move, 2 #n d0 lsl, d0 a0 add, d2 d3 .w move,
8 #n d3 .w lsr, eq
if, d2 a0 ) .b move, a0 3 )d .b clr,
else, d3 a0 ) .b move, d2 a0 3 )d .b move,
then, d1 a0 1 )d .b move, next;
: @attrib ( key# -- attrib )
local curkey curkey to
curkey ?keytest
if [ $inv ] literal
else 0
then curkey current-key =
if [ $bold ] literal
else 0
then or ;
: setkey$ ( key# -- ) ( Builds the key into lbuff )
local curkey curkey to
curkey @key$ dup 1 =
if drop curkey @attrib curkey @keypos !doublechar
else curkey @attrib curkey @keypos $>char
then ;
: kb-row1 ( keys 0 - D )
" [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ]" $>lbuff
0E 0 do i setkey$ loop 10 disp ;
: kb-row2 ( keys E - 1B )
" [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ]" $>lbuff
1C 0E do i setkey$ loop 12 disp ;
: kb-row3 ( keys 1C - 29 )
" [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ]" $>lbuff
2A 1C do i setkey$ loop 14 disp ;
: kb-row4 ( keys 2A - 36 )
" [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ]" $>lbuff
37 2A do i setkey$ loop 16 disp ;
: kb-row5 ( keys 37 - 3A )
" [ ] [ ] [ ] [ ]" $>lbuff
3B 37 do i setkey$ loop 18 disp ;
: kb-row6 ( keys 3B - 3C )
" [ ] [ ]" $>lbuff
3D 3B do i setkey$ loop 1A disp ;
: .kb-row ( row -- )
?dup
if dup 1 =
if kb-row1
else dup 2 =
if kb-row2
else dup 3 =
if kb-row3
else dup 4 =
if kb-row4
else dup 5 =
if kb-row5
else dup 6 =
if kb-row6
then
then
then
then
then
then drop
then ;
: nextkey ( key# -- nextkey# )
begin 1+ dup ?keytest 0= over 3c > or until ;
: keyboard-test
cls
" Keyboard Check" $>lbuff 0 disp
" KB Country Code:" $>lbuff
system.status [ country.code ] literal + @ ff xor ff and dup 0 18 #>lbuff
7f and country.name 0 22 $>char 2 disp
" Press the BOLD character key." $>lbuff 4 disp
" An error will sound a beep and leave that key highlighted." $>lbuff
6 disp
clr-keytest 0 current-key to
kb-row1 kb-row2 kb-row3 kb-row4 kb-row5 kb-row6
begin current-key @keyrow .kb-row
begin <key> clear-auto ff80 and ff80 <>
until scancode current-key @keyscan <>
if beep current-key setkey
then current-key dup nextkey current-key to
@keyrow current-key @keyrow over <>
if .kb-row else drop
then current-key 3c >
until " Press any key to return to Check Menu." $>lbuff 20 disp
begin <key> ff80 and ff80 <> until ;
( Main test words )
here target - .svlist to
( code #roms checksum0 checksum1 checksum2 )
( end of list is defined with a code FF )
0001 w, 00E60E37 , 0 , 0 ,
0201 w, 00EBAD0D , 0 , 0 ,
0402 w, 00D8F7B0 , 00D81208 , 0 ,
0803 w, 00B12FF1 , 00D6752E , 007FD7Df ,
1001 w, 00E60E37 , 0 , 0 ,
FF00 w, 0 , 0 , 0 ,
code ?svlist ( ccode -- addr )
.svlist #n a0 move, sp ) d0 move,
begin, a0 ) d0 .b cmp, ne
while, a0 ) d1 .b move, pl
if, 0E #n a0 add,
then, mi
until,
a0 sp ) move, next;
code @checksum.0high
romstart romsize + 10 - #n a0 move,
a0 0 )d d0 movep, d0 neg, d0 sp -) move, next;
code @checksum.0low romstart romsize + 10 - #n a0 move,
a0 1 )d d0 movep, d0 neg, d0 sp -) move, next;
code @checksum.1high
romstart romsize + 8 - #n a0 move,
a0 0 )d d0 movep, d0 neg,
d0 sp -) move, next;
code @checksum.1low
romstart romsize + 8 - #n a0 move,
a0 1 )d d0 movep, d0 neg,
d0 sp -) move, next;
code chksm+chksm
sp ) d0 move, d0 d1 move, d1 neg, 0 #n d2 moveq,
8 #n d1 rol, d1 d2 .b move, d2 d0 add,
8 #n d1 rol, d1 d2 .b move, d2 d0 add,
8 #n d1 rol, d1 d2 .b move, d2 d0 add,
8 #n d1 rol, d1 d2 .b move, d2 d0 add,
d0 sp ) move, next;
: chksum<> <>
if [ $inv ] literal
else 0
then ;
: .svroms
local recaddr
system.status [ country.code ] literal + @ not 7f and ?svlist recaddr to
" SV ROM0:" $>lbuff recaddr 2+ @ dup 0 18 #>lbuff8
system.status [ svrom0.chksum ] literal + @ dup rot chksum<> 22 #>lbuff8 12 disp
" SV ROM1:" $>lbuff recaddr 6 + @ dup 0 18 #>lbuff8
system.status [ svrom1.chksum ] literal + @ dup rot chksum<> 22 #>lbuff8 14 disp
" SV ROM2:" $>lbuff recaddr A + @ dup 0 18 #>lbuff8
system.status [ svrom2.chksum ] literal + @ dup rot chksum<> 22 #>lbuff8 16 disp
;
: $kbtest " [1] Keyboard Check" $>lbuff ;
: $crtadj " [2] CRT Adjustment" $>lbuff ;
: $fddadj " [3] FDD Adjustment" $>lbuff ;
: $fddclean " [4] FDD Head Cleaning" $>lbuff ;
: $format " [5] Format Disk" $>lbuff ;
: $fddtest " [6] FDD Check" $>lbuff ;
code country.list
nx ) jsr, ;c
" United States" dup 1+ c, here over allot swap cmove
" Canada" dup 1+ c, here over allot swap cmove
" United Kingdom" dup 1+ c, here over allot swap cmove
" Norway" dup 1+ c, here over allot swap cmove
" France" dup 1+ c, here over allot swap cmove
" Denmark" dup 1+ c, here over allot swap cmove
" Sweden" dup 1+ c, here over allot swap cmove
" Japan" dup 1+ c, here over allot swap cmove
" West Germany" dup 1+ c, here over allot swap cmove
" Netherlands" dup 1+ c, here over allot swap cmove
" Spain" dup 1+ c, here over allot swap cmove
" Italy" dup 1+ c, here over allot swap cmove
" Latin America" dup 1+ c, here over allot swap cmove
" South Africa" dup 1+ c, here over allot swap cmove
" Switzerland" dup 1+ c, here over allot swap cmove
" ASCII" dup 1+ c, here over allot swap cmove
" Unspecified" dup 1+ c, here over allot swap cmove
: country.name ( code -- addr len )
local ccode 10 min ccode to
country.list
begin dup c@ ccode 0= not
while -1 ccode +to +
again 1- swap 1+ swap ;
: .systemram
" System RAM: 00 01 02 03 10 11 12 13 20 21 22 23 30 31 32 33"
$>lbuff
system.status [ ramtest.results ] literal + @ dup 0F and
if 18 2 invert.chars
then 4 shr dup 0F and
if 1B 2 invert.chars
then 4 shr dup 0F and
if 1E 2 invert.chars
then 4 shr dup 0F and
if 21 2 invert.chars
then 4 shr dup 0F and
if 25 2 invert.chars
then 4 shr dup 0F and
if 28 2 invert.chars
then 4 shr dup 0F and
if 2B 2 invert.chars
then 4 shr 0F and
if 2E 2 invert.chars
then system.status [ ramtest.results 4 + ] literal + @ dup 0F and
if 32 2 invert.chars
then 4 shr dup 0F and
if 35 2 invert.chars
then 4 shr dup 0F and
if 38 2 invert.chars
then 4 shr dup 0F and
if 3B 2 invert.chars
then 4 shr dup 0F and
if 3F 2 invert.chars
then 4 shr dup 0F and
if 42 2 invert.chars
then 4 shr dup 0F and
if 45 2 invert.chars
then 4 shr 0F and
if 48 2 invert.chars
then 18 disp ;
: kbdcompatible? ( -- addr len \ -- 0 \ 0 means compatible )
local country kbdcountry country to ( identify keyboard language )
[ svrom0 ] literal @ magic#1 = ( svrom contains messages? )
if country svmsg? 0= ( yes, language represented in svrom? )
if country [ switzerland ] literal = ( kbd = swiss and native = german? )
nativerom [ wgermany ] literal = and ( yes, and correct svrom? )
[ italy ] literal svmsg? and 0= ( yes, use native ROMs )
if " Incompatible with svROM" exit ( incompatibility )
then then 0 ( everything is fine )
else compatibility ( svrom doesn't contain messages )
begin dup c@ dup 0ff <> ( ROM1 compatible with keyboard? )
while country =
if drop 0 exit then 1+ ( yes, return false )
again 2drop
" Incompatible with ROM1" ( no, return diagnostic msg )
then ;
: main-menu ( -- )
cls
" Canon Cat Self Diagnosis" $>lbuff 2 disp
" KB Country Code:" $>lbuff
system.status [ country.code ] literal + @ ff xor ff and dup 0 18 #>lbuff
7f and country.name swap over 0 22 $>char ( save name length >r stack )
kbdcompatible? ?dup ( Is keyboard compatible? )
if 22 over invert.chars ( no, invert keyboard country's name )
swap over 0 40 $>char
40 over invert.chars ( issue inverted message )
then drop ( discard name length )
6 disp
" ROM Checksums: True Read" $>lbuff 8 disp
" SYS ROM 0HIGH:" $>lbuff @checksum.0high dup 0 18 #>lbuff8
system.status [ 0high.chksum ] literal + @ dup rot
chksum<> 22 #>lbuff8 A disp
" SYS ROM 0LOW:" $>lbuff @checksum.0low dup 0 18 #>lbuff8
system.status [ 0low.chksum ] literal + @ dup rot
chksum<> 22 #>lbuff8 C disp
" SYS ROM 1HIGH:" $>lbuff @checksum.1high
chksm+chksm dup 0 18 #>lbuff8
system.status [ 1high.chksum ] literal + @ dup rot
chksum<> 22 #>lbuff8 E disp
" SYS ROM 1LOW:" $>lbuff @checksum.1low
chksm+chksm dup 0 18 #>lbuff8
system.status [ 1low.chksum ] literal + @ dup rot
chksum<> 22 #>lbuff8 10 disp
.svroms ( Displays on half rows 0E-14 )
.systemram
" SV RAM:" $>lbuff system.status [ svtest.results ] literal +
@ if 0 [ $inv ] literal else 2000 0 then 18 #>lbuff8 1A disp
" Manual Check Menu: Select [1] [2] [3] [4] [5] [6]" $>lbuff 1E disp
$kbtest 22 disp
$crtadj 24 disp
$fddadj 26 disp
$fddclean 28 disp
$format 2A disp
$fddtest 2C disp ;
: main-test ( MT 6/2/87 )
local curkey
[ svrom0 ] literal [ svrom0len ] literal chksumbyte
system.status [ svrom0.chksum ] literal + !
system.status [ svrom1.chksum ] literal + !
[ svrom1 ] literal [ svrom1len ] literal chksumbyte
system.status [ svrom2.chksum ] literal + ! drop
begin main-menu
begin <key> dup curkey to
stripshifts spc = ?ctl and ?shift and
if edde off crt on abort
then curkey FF00 and 0=
until curkey FF and curkey to curkey 31 =
if keyboard-test
else curkey 32 =
if crt-test
else curkey 33 =
if disk-adjust
else curkey 34 =
if disk-clean
else curkey 35 =
if $format bold-line 2A disp <format>
if beep
then
else curkey 36 =
if disktest
else beep
then
then
then
then
then
then
again ;
( End of High Level Diagnostic Words )
( job88jan20, to mar21 Fast Cat Serial Link Code)
: sset ( -> | Initialize the translation table and, If necessary, set the
serial port to 38400bps, 8 data, no parity, 1 stop. This may be version
dependent)
100 0 do i xlate i + c! loop ( init translation table) ;
frag get1 to ( Get a byte and return it in d0, assumes d1 has watchdog timer
bit set along with the other bits that are supposed to be set.)
begin, 0 #n duart ser.sra + .b btst, eq ( if there is no rx character)
while, d1 opr .b move, ( call off the watchdog) 1 #n 400000 addq, ( twinkle)
again, duart ser.rhra + d0 .b move, ( get rx ch) rts, ;c
frag get4 to ( Get 4 bytes and return them in d0, d2 used.)
3 #n d2 moveq,
begin, 8 #n d0 lsl, ( the first time, who cares. Just don't shift after last ch)
get1 jsr, d2 nt
-until, rts, ;c
code <get> ( r -> n da s1 s2 ba xa lcs rcs ccs 1 | Normal receive
r -> n da s1 s2 ba xa lcs 0 | bad leader
r -> -1 | not enough room
Receive serial transmissions of not more than r bytes and put data in ram.
Return all parameters: number of received data bytes, data destination address,
spare 2, spare 1, breakpoint addr., execution addr., leader checksum, received
data checksum, computed data checksum and leader status flag)
i' system.status a0 move, a0 ga2opr )d d1 .b move, ( get opr bit pattern)
( TC: If not in target compiler, use this: system.status addr a0 move,)
8 #n d1 .b or, ( set the watchdog timer reset bit, bit 3, on)
sp )+ d3 move, ( get the available room) 0 #n d0 moveq, ( clear out d0)
begin, ( discard nonsync ch.) get1 jsr, 99 #n d0 cmp, eq until,
begin, ( discard sync ch.) get1 jsr, 99 #n d0 cmp, ne until,
( now we have the high byte of the count) 2 #n d2 moveq,
begin, 8 #n d0 lsl, get1 jsr, d2 nt -until, ( now we have the count)
-1 #n d0 cmp, ne
if, ( not to shadowram, do the size compare) d0 d3 cmp, lt
if, ( not enough room) -1 #n d0 moveq, d0 sp -) move, next, then,
then, d0 d3 move, ( save the count for a while)
d0 sp -) move, ( stack the count)
0 #n a0 move, ( clear for leader checksum) d0 a0 add, ( start sum)
get4 jsr, d0 a0 add, ( sum)
i' gap a1 move, ( files go to gap) a1 sp -) move, ( stack gap)
( TC: If not In target compiler do this: gap addr a1 move,)
-1 #n d3 cmp, eq ( this test must come after the checksumming is done)
if, ( going to shadow ram, fix up stack)
sp )+ d0 move, sp )+ d0 move, ( discard old values)
40000 #n d3 move, d3 sp -) move, ( fix count)
a00000 #n a1 move, a1 sp -) move, ( fix destination address)
then, ( get the balance of the header)
get4 jsr, d0 sp -) move, ( stack spare 2) d0 a0 add, ( sum)
get4 jsr, d0 sp -) move, ( stack spare 1) d0 a0 add, ( sum)
get4 jsr, d0 sp -) move, ( stack the breakpoint addr) d0 a0 add, ( sum)
get4 jsr, d0 sp -) move, ( stack the execution addr) d0 a0 add, ( sum)
get4 jsr, d0 sp -) move, ( stack the incoming leader checksum)
d0 a0 cmp, eq ( is the header checksum ok?)
if, d3 swap, d3 d2 .w move, d3 swap, ( get low & high words)
i' xlate a0 move, ( the base address of character translation table)
( TC: If not in target compiler, use this: xlate #n a0 move,)
d4 sp -) move, ( save d4) 0 #n d4 moveq, ( clear it for checksumming)
0 #n d0 moveq, ( clear d0) 1 .b bra, ( & dec. counters before looping)
begin, ( cascade counters, each -until can go for 16 bits so the total...)
begin, ( can be a full 32 bit count and still use the fast -until loop)
get1 jsr, 1 #n 400004 addq, ( twinkle on data too during receive)
d0 d4 add, ( checksum it) a00000 #n a1 cmp, lt ( in text ram?)
if, a0 d0 0 xw)d a1 )+ .b move, ( translate ch & put in text ram)
else, d0 a1 )+ .b move, ( put it in shadow ram as is)
then, 1 :l ( loop entrance) d3 nt
-until, d2 nt
-until,
get4 jsr, ( receive checksum) d4 d2 move, ( get computed checksum)
sp )+ d4 move, ( restore d4) d0 sp -) move, ( stack received checksum)
d2 sp -) move, ( stack computed checksum)
1 #n d0 moveq, ( finaly, prepare to stack the leader ok flag)
else, 0 #n d0 moveq, ( or, prepare to stack the bad leader flag)
then, d0 sp -) move, next;
: get ( -> | Receive characters from the serial port and put them in RAM.
Report any errors.)
local ccs local rcs local lcs local default
55555555 default to default dup dup lcs to rcs to ccs to
sset ( set xlate table and serial channel bit rate, etc.)
pb xlate 60 ( accent grave) + c! ( xlate incoming accent grave to page break)
( for 1.74: use commport? in lieu of sendport?, below )
sendport? off cts.off rts.off dsr.off dtr.off ( kill handshakes for now)
beot eor = ( is the cursor on the last Document break? )
if ( back gap up ) beot prevchar eos to eos prevchar bos to movegap
then 7fffffff needtext drop 10 - ( compute the text room )
ioff <get> ion dup 1 =
if ( leader ok) drop ( flag) 2dup <> ( are the data checksums unmatched?)
if boop ccs to rcs to ( save unmatched checksums)
else 2drop ( they are ok, don't restack at end) beep
then drop ( leader checksum)
else ( checking flag again drops it)
if ." Not enough room " boop ( cts.on) exit
else boop lcs to
then
then execution to break to spare2 to spare1 to
dataaddr to datasize to ( put all parameters away)
lcs default = rcs default = and ccs default = and ( error free?)
datasize beot gap - 8 - > not and ( and the data fits)
if ( ok) datasize gap +to ( repoint gap) preset
bot eot 1+ killivls
selected bos nextchar bos to bos op to ( set bos)
rewindow redisplay extendedcursor equit ( return to edde)
else lcs default <> if lcs ." Bad leader checksum stacked " then
rcs default <> ccs default <> or
if rcs ccs ." Unmatched data checksums stacked " then
then ( cts.on) 60 xlate 60 + c! ( restore accent grave) ;
code sendchsx ( a n -> | Transmit n characters from RAM begining at a)
sp )+ d0 move, d0 swap, d0 d1 .w move, d0 swap, ( get low & high words)
i' system.status a0 move, a0 ga2opr )d d2 .b move, ( get opr bit pattern)
( TC: If not in target compiler, use this: system.status addr a0 move,)
8 #n d2 .b or, ( set the watchdog timer reset bit, bit 3, on)
i' xlate a0 move, ( the base address of character translation table)
( TC: If not in target compiler, use this: xlate #n a0 move,)
sp )+ a1 move, ( finally, get the destination address)
0 #n d3 moveq, ( clear d3) 1 .b bra, ( & decrement the counters before looping)
begin, ( cascade counters, each -until can go for 16 bits so the total ...)
begin, ( can be a full 32 bit count and still use the fast -until loop)
a1 )+ d3 .b move, ( get a character from ram)
begin, 2 #n duart ser.sra + .b btst, eq ( if the tx is not ready)
while, d2 opr .b move, ( call off the watchdog)
again, a0 d3 0 xw)d duart ser.rhra + .b move, ( translate ch & transmit)
1 :l ( loop entrance) d0 nt
-until, d1 nt
-until, next;
code sendchx ( ch -> ch' | Send ch out serial port, stack translated ch sent)
0 #n d0 moveq, sp 3 )d d0 .b move, ( get character)
i' xlate a0 move, ( the base address of character translation table)
( TC: If not in target compiler, use this: xlate #n a0 move,)
a0 d0 0 xw)d d0 .b move, ( translate character)
begin, 2 #n duart ser.sra + .b btst, ne ( loop if the tx is not ready)
until, d0 duart ser.rhra + .b move, ( send ch)
d0 sp ) move, ( stack translated character) next;
: sendleader ( n -> | Make and send leader with datasize set to n)
leader 20 55 fill 99999999 leader ! ( sync chs) leader 4 + ! ( size)
leader 1c <cksum4> leader 1c + ! leader 20 sendchsx 400 ms ;
: sendselection ( -> | Send selected data, discarding wierd things in the text)
sset ( set the serial channel bit rate, etc.)
0 ( count) bos 1- begin ( counting characters in selection) nextchar dup gap <
while swap 1+ ( bump count) swap
again drop ( floating text pointer) sendleader
60 dup xlate pb + c! xlate ds + c! ( change pb's & ds's to 60, an accent grave)
0 ( accum) bos 1- begin ( sending and checksumming chs) nextchar dup gap <
while dup c@ sendchx rot + ( checksum xlated ch) swap
again drop ( floating text pointer) trailer !
pb xlate pb + c! ds xlate ds + c! ( fix table back before sending trailer)
trailer 4 sendchsx ( send trailer) collapse ( selection) ;
: sendimage ( -> | Send the shadow ram contents, ASAP)
sset ( set the serial channel bit rate, etc.) a00000 40000 <cksum> trailer !
40000 sendleader ioff a00000 40000 sendchsx ion trailer 4 sendchsx ;
( TC: If using the target compiler, comment out the following three lines and
load these usefront keys when the others are target compiled)
( ' get c' inittables 6 + @ 0a 2* + w! ( usefront r to get)
( ' sendselection c' inittables 6 + @ 2c 2* + w! ( usefront s to sendselection)
( ' sendimage c' inittables 6 + @ 13 2* + w! ( usefront i to sendimage)
( country code default array )
( country code default array )
code defcountry nx ) jsr, ;c
( A 17 row by 16 byte array of country code default information. Each row
consists of 10 bytes of bit information for tabs and then 1 byte each for the
codes for: external modem, paper size, top margin, bottom margin, number
punctuation and one byte for the spelling checker and keyboard I/II flags.
|<---- regular tabs ---->| empstmbm npsk Country extra room if needed)
00100208 , 20800002 , 0000 w, 00000200 , 00ff w, ( USA)
00100208 , 20800002 , 0000 w, 00000200 , 00ff w, ( Canada)
00102080 , 00020802 , 0000 w, 01020201 , 00ff w, ( UK)
00100208 , 20800002 , 0000 w, 01020200 , 0100 w, ( Norway)
00082080 , 00020820 , 0000 w, 01020200 , 01f0 w, ( France)
00100208 , 20800002 , 0000 w, 01020200 , 0100 w, ( Denmark)
00100208 , 20800002 , 0000 w, 01020200 , 0100 w, ( Sweden)
00100208 , 20800002 , 0000 w, 00020200 , 000f w, ( Japan)
00040104 , 10400001 , 0000 w, 01020300 , 01f0 w, ( W. Germany)
00100208 , 20800002 , 0000 w, 01020200 , 0100 w, ( Netherlands)
00000104 , 10400001 , 0400 w, 01020200 , 0100 w, ( Spain)
00100208 , 20800002 , 0000 w, 01020200 , 0100 w, ( Italy)
00100208 , 20800002 , 0000 w, 01000200 , 000f w, ( Latin Am.)
00100208 , 20800002 , 0000 w, 01020200 , 000f w, ( S. Africa)
00100208 , 20800002 , 0000 w, 01020200 , 020f w, ( Switzerland)
00100208 , 20800002 , 0000 w, 00000200 , 00ff w, ( ASCII)
00100208 , 20800002 , 0000 w, 00000200 , 00ff w, ( Dvorak)
( Note on tabs: The tab position information is in the bit positions of a data
area tabcount bytes long in data vectors such as #defaults and ##ctrl
which are used by tab words like Tabs , Deftabs and tabloop . The offset
of the tab data area of these arrays is given by %tabs . The tab positions,
starting at text column 1, start at bit 0 of the first byte in the tab data
area and go up to bit 7 of that byte and then to bit 0 of the byte at the next
higher address and so on. For example, if you executed:
#defaults %tabs + c@ . 21
then, since bits 0 and 5 of the first tab data byte are set, the first two tab
positions would be at text columns 1 and 6. The first 10 bytes of the tab data
area define the normal tab settings for all 80 columns and the second 10 bytes
define the positions of the decimal tabs for the corresponding 80 columns.)
code svramspell>temp ( -> | Move svram spelling dictionary to temporary ram)
svfree 4 / 1- #n d0 .w move, ( get count for spell move loop)
svram #n a0 move, ( get start of svram)
i' trkbuf a1 move, ( get temp storage location of svram )
begin, a0 0 )d d1 movep, ( read svram) d1 a1 )+ move, ( write to temp area)
8 #n a0 addq, ( Increment the sv address) d0 nt
-until, next;
code temp>svramspell ( -> | Move temporary ram to svram spelling dictionary)
svfree 4 / 1- #n d0 .w move, ( get count for spell move loop)
svram #n a0 move, ( get start of svram)
i' trkbuf a1 move, ( get temp storage location of svram )
begin, a1 )+ d1 move, ( read svram temp area) d1 a0 0 )d movep, ( write svram)
8 #n a0 addq, ( increment the sv address) d0 nt
-until, next;
code svramsetup>temp ( -> | Move svram setup data to temporary ram)
svramlen svfree - 4 / 1- #n d0 .w move, ( get count for setup move loop)
svram svfree 2* + #n a0 move, ( get start of svram free area)
i' trkbuf a1 move, ( get temp storage location )
begin, a0 0 )d d1 movep, ( read svram) d1 a1 )+ move, ( write to temp area)
8 #n a0 addq, ( Increment the sv address) d0 nt
-until, next;
code temp>svramsetup ( -> | Move temporary ram to svram setup data area)
svramlen svfree - 4 / 1- #n d0 .w move, ( get count for setup move loop)
svram svfree 2* + #n a0 move, ( get start of svram free area)
i' trkbuf a1 move, ( get temp storage location )
begin, a1 )+ d1 move, ( read svram temp area) d1 a0 0 )d movep, ( write svram)
8 #n a0 addq, ( increment the sv address) d0 nt
-until, next;
: setup>temp ( -> | Move setup data to temporary ram ready to write to svram)
system.status [ startsvss ] literal + ( the source address)
trkbuf [ svramlen svfree - ] literal + ( end of setup data in temp area)
[ endsvss startsvss - ] literal ( actual size of setup data + cksums)
dup >r ( this is the count, save a copy) - ( the destination address)
r> ( count) move ;
: temp>setup ( -> | Move setup data from temporary ram to system.status ram)
trkbuf [ svramlen svfree - ] literal + ( end of setup data in temp area)
[ endsvss startsvss - ] literal ( actual size of setup data + cksums)
dup >r ( this is the count, save a copy) - ( the source address)
system.status [ startsvss ] literal + ( destination address) r> ( count) move ;
: svid ( -> id | Stack the svram id numbers, spelling in upper 16 bits and
setup id in lower 16 bits)
00040015 ( ** update this every time the svram layout is changed!!! ** ) ;
: svid@ ( -> s | Fetch the saved svram id)
system.status [ svid ] literal + @ not ( bitwise inverse) ;
: svid! ( s -> | Store the saved svram id)
not ( bitwise inverse) system.status [ svid ] literal + ! ;
: spellcs ( -> s | Report the svram spelling checksum from temp area)
trkbuf [ svspelllen ] literal <cksum> ;
: svspellcs@ ( -> s | Fetch the stored svram spelling checksum)
system.status [ svspellcs ] literal + @ not ( bitwise inverse) ;
: svspellcs! ( s -> | Store the stored svram spelling checksum)
not ( bitwise inverse) system.status [ svspellcs ] literal + ! ;
: wheel@ ( -> s | Get the spare byte from svram)
system.status [ svspare ] literal + c@ ;
: wheel! ( s -> | Set the spare byte in svram)
dup 73 78 inrange if drop 72 then system.status [ svspare ] literal + c! ;
: rom>svsetup? ( -> flg | True if svram setup data from rom)
system.status [ svsetupflg ] literal + c@ 0= 0= ;
: rom>svsetup! ( flg -> | Set svram setup data from rom flag)
system.status [ svsetupflg ] literal + c! ;
: setupcs ( -> s | Report the setup data checksum from system.status)
system.status [ startsvss ] literal + ( address)
[ endsvss startsvss - 8 - ] literal ( count less checksums) <cksum> ;
: svsetupcs@ ( -> s | Fetch the stored svram setup data checksum)
system.status [ svsetupcs ] literal + @ not ( bitwise inverse) ;
: svsetupcs! ( s -> | Store the stored svram setup data checksum)
not ( bitwise inverse) system.status [ svsetupcs ] literal + ! ;
: himsetup ( k -> addr | Get the k-th item's himsetup data address in the setup
system area)
dup 0 [ himsetuplim 2* 1- ] literal inrange not abort" Bad hidden internal
modem setup index attempted" 2* system.status [ himsetup ] literal + + ;
: #defaults ( -> addr | Get the address of format default data in the setup
system area)
system.status [ #defaults ] literal + ;
: kbdcountry ( -> cc | Stack the decoded country code )
0ff dup [ country.code ] literal system.status + @ and xor ( mask & comp lsb)
dup 0 [ cclim ] literal inrange not if drop [ usa ] literal then ;
( **: exmodem! ( n -> | Store n in the external modem flag in setup's ram area)
( [ externalmodem ] literal system.status + c! ;)
( **: exmodem@ ( n -> | Fetch n from the external modem flag in setup's ram
area)
( **[ externalmodem ] literal system.status + c@ ;)
: checkspell! ( n -> | Store n in the spelling checker flag in setup's ram)
[ checkspell ] literal system.status + c! ;
: checkspell@ ( n -> | Fetch n from the spelling checker flag in setup's ram)
[ checkspell ] literal system.status + c@ ;
: kbdI/II! ( n -> | Store n in the keyboard I/II flag in setup's ram area)
[ kbdI/II ] literal system.status + c! ;
: kbdI/II@ ( -> n | Fetch n from the keyboard I/II flag in setup's ram area)
[ kbdI/II ] literal system.status + c@ ;
( *** : initsetup was initially here)
: savesetup
setupcs svsetupcs! ( set checksum)
setup>temp temp>svramsetup ( save in svram svram) ;
: savespell
svramspell>temp spellcs svspellcs! savesetup ;
: getsetupspell ( sef spf -> | Recover the setup and/or spell information from
disk if flagged)
local sef local spf local spcs local secs ( for checksums) local readerror
local oldspcs ( old spelling checksum)
spf to ( save spell flag) sef to ( save setup flag)
spf sef or ( fetch existing checksums, either condition needs them)
if idblock f8 @ptr svid <> or trkbuf 1 rtrk or readerror to
readerror 0= ( entirely error free?)
if trkbuf [ svramlen svfree - 8 - ] literal + ( checksum start in temp)
dup @ not spcs to 4 + @ not secs to ( remember both checksums )
sef ( get the setup information?)
if svspellcs@ oldspcs to ( save the current spelling cksum)
trkbuf [ svramlen svfree - ] literal + ( end of setup data in temp)
[ endsvss startsvss - ] literal ( size of setup data + cksums)
dup >r ( this is the count, save a copy) - ( the starting address)
r> 8 - ( count less trailing checksums) <cksum> ( setup in temp)
secs = ( is the setup checksum from disk ok?)
if temp>setup ( put setup info in system.status)
thisdocdata ( pick up the current document data)
oldspcs svspellcs! ( restore the old spelling checksum)
else setupcs svsetupcs@ <>
if initsetup ( inits & sets only the setup cksum)
( else leave the old setup alone, it's better than inited)
dirtytext? on ( but make the text dirty anyway)
then
then
then spf ( get the spell information?)
if trkbuf 2 rtrk dup readerror or readerror to 0=
if spellcs spcs =
if temp>svramspell ( put info in svram)
spcs ( good cksum) svspellcs! ( set only this)
else svramspell>temp spellcs svspellcs@ <>
if initdictionary ( original was bad, must do this)
svramspell>temp spellcs svspellcs! ( set only this)
( else leave it alone, it is better than init)
dirtytext? on ( but make the text dirty anyway)
then
then
then
then
then readerror parksafe or
if mCRSS error
then ( save setup, as is, to svram) setup>temp temp>svramsetup
then doff ;
: initsvram ( -> | Test svram data, initialize from rom if necessary )
local newspell local newsetup ( places to keep the svram flags)
svramsetup>temp ( 1st., copy setup to temp) temp>setup ( 2nd., to system.status)
svid svid@ xor dup ffff0000 and 0= 0= newspell to ffff and 0= 0= newsetup to
svramspell>temp ( 3rd. copy spelling dictionary from svram to temp)
spellcs ( done from temp) svspellcs@ ( from system.status) <> newspell or
if initdictionary ( in place in the svram)
svid ffff0000 and svid@ ffff and or svid! ( set spelling id)
then setupcs svsetupcs@ ( both from system.status) <> newsetup or ( setup ok?)
dup ( save a copy of this flag, initsetup will clear it, regardless)
if initsetup ( copy from rom, set flags)
svid ffff and svid@ ffff0000 and or svid! ( set setup id)
then rom>svsetup! ( now set the copied-from-rom flag in system.status)
savespell ( validate entire svram)
( now setup the simple things in the Cat using a preset setup data vector)
0 getdata 0 oldsetdata [ setv&tlim 2* ] literal ( source destination count)
move ( make all things the same so it won't call redoc and set dirty flag)
setupcat ( sets up the simple things but doesn't set dirty flag or call redoc) ;
startgroup ( Cat180 printer)
1 groupl +to ( to make room for the title line)
: m18dw
m180 3 [ groupl 1- ] literal ultype ( title line)
mDW 6 [ setv&ti ] literal [ groupl ] literal mDWchoice ;
0 setv&t m18dw drop
none setv&t noop ( alignment dummy) -1 groupl +to ( don't display it) drop
: m18pitch
[ groupl ] literal [ setv&ti ] literal mpitch ;
0 setv&t m18pitch drop
: m18g
[ groupl ] literal [ setv&ti ] literal dispgutter ;
0 setv&t m18g drop
: m18d
[ setv&ti ] literal [ groupl ] literal mdirection ;
0 setv&t m18d drop
: m18csf
mCSF 6 [ setv&ti ] literal [ groupl ] literal myesno ;
1 setv&t m18csf drop
none setv&t noop ( alignment dummy) -1 groupl +to ( don't display it) drop
: m18pbs
mPBS 6 [ setv&ti ] literal [ groupl ] literal myesno ;
0 setv&t m18pbs drop
: mpc0 ['] CAT180 mpc.0 ;
0 Cat180pop to ( Cat 180 only parallel, set target compiler integer to be sure)
: mpc1 ['] LBP mpc.1 ;