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.

5320 lines
208 KiB

( disk C, side 1)
( disk C, side 1)
code alast ( == a )
awide #n i' asp add, next;
code adrop ( a == )
awide #n i' asp sub, next;
: anew ( -- )
astack asp to
astack awide 2* - adeep awide * 0 fill
mtable awide 0a * + awide -1 fill ;
code NaN ( == NaN )
awide #n i' asp add, i' asp a0 move,
08 #n a0 ) .b move, next;
code uNaN ( == uNaN )
awide #n i' asp add, i' asp a0 move,
0c #n a0 ) .b move, next;
code afalse ( == 0 )
;c
code 0. ( == 0 )
awide #n i' asp add, i' asp a0 move,
0 #n a0 )+ move, 0 #n a0 )+ move, 0 #n a0 ) move, next;
( stack operations )
code adup ( a == a a )
i' asp a1 move, awide #n i' asp add, i' asp a0 move,
a1 )+ a0 )+ move, a1 )+ a0 )+ move, a1 )+ a0 )+ move, next;
code aswap ( a b == b a ) i' asp a0 move, a0 a1 move,
awide #n a1 sub, awide 2/ #n d0 move,
begin, a0 ) d1 move, a1 ) a0 )+ move, d1 a1 )+ move,
1 #n d0 subq, eq until, next;
code aover ( a b == a b a ) awide #n i' asp add,
i' asp a0 move, a0 a1 move, awide 2* #n a1 sub,
a1 )+ a0 )+ move, a1 )+ a0 )+ move, a1 ) a0 ) move, next;
code arot ( a b c == b c a ) i' asp a0 move, a0 a1 move,
awide #n a0 sub, awide 2* #n a1 sub, awide 2/ #n d0 move,
begin, a0 ) d1 move, a1 ) a0 )+ move, d1 a1 )+ move,
1 #n d0 subq, eq until, next;
code a- ( a b == a-b | negate top operand )
i' asp a0 move, a0 ) d0 .b move, 8 #n d0 .b and, eq
if, 1 #n a0 ) .b eor, then, ;c
code a+ ( a b == a+b )
i' asp a1 move,
0 #n d2 moveq, a1 ) d2 .b move, a1 ) .b clr, ( get sign )
awide #n i' asp sub, i' asp a0 move, ( adrop )
d2 d0 move, a0 ) d0 .b move, a0 ) .b clr, ( get sign )
d0 d3 move, d2 d3 .b or, 08 #n d3 .b and, ne ( a NaN? )
if, d2 a1 ) .b move, d0 a0 ) .b move, 08 #n d2 and, ne
if, awide 2 shr #n d0 moveq, ( move NaN into answer )
begin, a0 ) d1 move, a1 ) a0 )+ move, d1 a1 )+ move,
1 #n d0 subq, eq until, then, next, then,
a0 sp -) move, a1 sp -) move, 1 #n d0 .b and, ( save addr )
1 #n d2 .b and, d2 d0 .b cmp, eq ( compare signs )
if, awide #n d1 moveq, d1 a0 add, d1 a1 add, ( same signs )
1 #n d1 subq,
begin, a1 -) a0 -) abcd, d1 nt -until, ( add elements )
else, awide 2/ 1- #n d1 moveq, ( different signs )
begin, a1 )+ d3 .w move, a0 )+ d2 .w move, ( subtract )
d3 d2 sub, ne if, lt ( if a0<a1 branch )
if, 1 #n d0 .b eor, ( top is larger, change sign )
awide 2 shr 1- #n d2 moveq, ( and swap operands )
sp )+ a1 move, sp ) a0 move, a1 sp -) move,
begin, a0 ) d3 move, a1 ) a0 )+ move, d3 a1 )+ move,
d2 nt -until,
then, 1 bra, ( comparison is complete, jump out of loop )
then, d1 nt
-until, 0 #n d0 moveq, 1 :l ( equal: clear sign )
sp )+ a1 move, sp ) a0 move, a1 sp -) move,
awide #n d1 moveq, d1 a0 add, d1 a1 add, 1 #n d1 subq,
023c00ef , ( 00ef #n ccr and, | turn X bit off in condition code reg )
begin, a1 -) a0 -) sbcd, d1 nt -until,
then, sp )+ a0 move, sp )+ a0 move,
a0 ) d1 .b move, ne
if, 08 #n d0 .b eor,
then, d0 a0 ) .b move, next;
code acompare ( a b == | -- flag{-1,0,1} <<or>> a b == NaN )
i' asp a1 move, awide #n d1 moveq, d1 i' asp sub, ( a1: b, adrop )
i' asp a0 move, a0 sp -) move, ( a0: a, save a's adr )
0 #n d2 moveq, a1 ) d2 .b move, a1 ) .b clr, ( d2: sign of b )
d2 d0 move, a0 ) d0 .b move, a0 ) .b clr, ( d0: sign of a )
d0 d3 .b move, d2 d3 .b or, 08 #n d3 .b and, ne ( d3: combined ", NaN? )
if, d2 a1 ) .b move, d0 a0 ) .b move, ( replace signs )
08 #n d0 and, eq ( a <> NaN? )
if, awide 2 shr 1- #n d0 moveq, ( swap NaN w/ non-NaN )
begin, a1 ) d1 move, a0 ) a1 )+ move, d1 a0 )+ move, d0 nt -until,
then, 4 #n sp addq, tc' <exit> jmp, ( drop addr of a )
then, d1 i' asp sub, d2 d0 cmp, eq ( adrop, compare signs )
if, 0 #n d2 cmp, ne ( same sign, both neg? )
if, a0 d3 move, a1 a0 move, d3 a1 move, then, ( yes )
begin, a1 )+ a0 )+ .b cmp, ne if, cs
if, -1 #n sp ) move, else, 1 #n sp ) move, then, next,
then, 1 #n d1 subq, eq
until, 0 #n sp ) move,
else, 1 #n d2 lsl, 1 #n d2 sub, d2 sp ) move, then, next;
code ?aflag ( flag -- | == flag )
sp )+ d0 move, eq if, tc' afalse jmp, then, ;c
code atrue ( == 1 )
awide #n i' asp add, i' asp a0 move,
0 #n a0 )+ move, 100 #n a0 )+ move, 0 #n a0 ) move, next;
code aneg ( a == -a )
i' asp a0 move, a0 a1 move, awide 2 shr 1- #n d0 moveq,
begin, 0 #n a1 )+ cmp, d0 ne -until, ne
if, 1 #n a0 ) .b eor, then, next;
code aabs ( a == |a| )
i' asp a0 move, 0 #n a0 ) .b bclr, next; ( clear flag bit )
code aint ( a == int(a)
i' asp a0 move, awhole 2/ 1+ #n a0 addq,
awide 2/ 1- #n d0 moveq,
begin, 0 #n a0 )+ .b move, d0 nt -until, next;
: a<
acompare 0< ?aflag ;
: a>
acompare 0 > ?aflag ;
: a=
acompare 0= ?aflag ;
: a~
afalse acompare 0= ?aflag ;
: a|
afalse acompare afalse acompare or ?aflag ;
: a&
afalse acompare afalse acompare and ?aflag ;
code <muls> ( a b == a | -- sign asp[b] )
0 #n d0 moveq,
i' asp a0 move, a0 ) d0 .b move, a0 ) .b clr, ( get sign )
awide #n i' asp sub, d0 d1 move, ( adrop )
i' asp a1 move, a1 ) d1 .b move, a1 ) .b clr, ( get sign )
d0 d3 .b move, d1 d3 .b or, 08 #n d3 .b and, ne
if, d1 a1 ) .b move, d0 a0 ) .b move, 08 #n d0 and, ne
if, awide 2 shr #n d0 moveq,
begin, a0 ) d1 move, a1 ) a0 )+ move, d1 a1 )+ move,
1 #n d0 subq, eq until,
then, tc' <exit> jmp, ( don't finish )
then, d1 d0 .b eor, 1 #n d0 .b and, d0 sp -) move, ( save sign )
a1 sp -) move, a0 sp -) move, ( save asp[b] & asp[a] addrs )
mtable #n a1 move, ( move op to mtable )
a0 )+ a1 )+ move, a0 )+ a1 )+ move, a0 )+ a1 )+ move,
a1 d1 move, sp )+ a1 move, sp ) a0 move, ( copy a to b )
a0 )+ a1 )+ move, a0 )+ a1 )+ move, a0 )+ a1 )+ move, d1 a1 move,
mtable #n a0 move, 8 #n d1 moveq, ( build multiples table )
begin, ( copy last element to next )
a0 )+ a1 )+ move, a0 )+ a1 )+ move, a0 )+ a1 )+ move,
mtable awide + #n a0 move, awide 1- #n d0 moveq,
begin, a0 -) a1 -) abcd, d0 nt -until, ( add 1st to last )
a1 a0 move, awide #n a1 add,
d1 nt -until, aacum #n a0 move, 5 #n d0 moveq,
begin, 0 #n a0 )+ move, d0 nt -until, ( clear accumulator )
0 #n a0 )+ .b move, next;
code <a*> ( a == a*b | sign asp[b] -- flag
multiplication -- extract digit, lookup product )
2 #n d0 moveq, ( d1 = offset )
sp ) sp -) move, awide #n sp ) add, ( sp = asp )
begin, d0 d1 move, 1 #n d1 lsr,
sp ) a0 move, d1 a0 sub, ( a0 = asp )
a0 ) d2 .b move, ( d2 = char )
0 #n d0 btst, ne ( is digit odd? )
if, 0f0 #n d2 and, 4 #n d2 lsr,
else, 0f #n d2 and,
then, ne ( mult by non-zero? )
if, mtable #n a0 move, 2 #n d2 subq, pl ( select multiple )
if, begin, awide #n a0 add, d2 nt -until, ( a0 = addr of mult )
then, ( shift left, add )
0 #n d0 btst, ne ( is digit odd? )
if, atemp #n a1 move, ( yes, move to temp, shift temp )
a0 )+ a1 )+ move, a0 )+ a1 )+ move, a0 )+ a1 )+ move,
0 #n a1 ) .b move, atemp #n a0 move, 2 #n d3 moveq,
begin, a0 ) d1 move, 4 #n d1 lsl, ( shift left 1 nybble )
0 #n d2 moveq, a0 4 )d d2 .b move, 4 #n d2 lsr,
d2 d1 or, d1 a0 )+ move, d3 nt
-until, atemp #n a0 move, ( use temp in addition )
then, aacum awide 2* + #n a1 move, d0 d1 move,
1 #n d1 .b lsr, d1 a1 sub, awide #n d1 moveq, d1 a0 add,
1 #n d1 subq,
begin, a0 -) a1 -) abcd, d1 nt -until, ( add to result )
then, 1 #n d0 addq, awide 2* #n d0 cmp, eq
until, sp )+ a0 move, ( drop; round answer )
around #n a0 move, 1 #n d0 moveq, ( store true flag in d0 )
a0 ) d1 move, 50000000 #n d1 cmp, eq ( nearly halfway? )
if, a0 4 )d d1 .b move, eq ( exactly? )
if, a0 -4 )d d0 move, 1 #n d0 and, then, ( even -> false )
else, mi ( not nearly, less than halfway? )
if, 0 #n d0 moveq, ( yes -> false )
then, then, d0 tst, ne ( d0 = 0 means don't round )
if, atemp #n a0 move, 0 #n a0 )+ move, 0 #n a0 )+ move,
1 #n a0 )+ move, ( temp = .0000000001 )
aresult awide + #n a1 move, awide 1- #n d1 moveq,
begin, a0 -) a1 -) abcd, d1 nt -until, ( add .0000000001 )
then, aresult #n a0 move, ( place result in operand )
sp ) a1 move, ( a1 = address of operand )
a0 )+ a1 )+ move, a0 )+ a1 )+ move, a0 )+ a1 )+ move,
sp )+ a1 move, sp ) d0 move, ne
if, a1 a0 move, a0 )+ d0 move, a0 )+ d0 or, a0 )+ d0 or, ne
if, 1 #n a1 ) .b move, ( set neg flag )
then, then, sp )+ a0 move, ( drop )
aacum #n a0 move, a0 )+ d0 move, a0 )+ d0 .w or, a0 )+ d0 .b or,
d0 tst, ne if, 8 #n a1 ) .b move, then, ( overflow: set NaN flag )
next;
code <a/> ( a == a/b | sign answer -- flag )
( copy dividend to aacum+awhole/2 )
sp ) a0 move, aacum awhole 2/ + #n a1 move,
( this won't work if constant in a1 isn't even )
a0 )+ a1 )+ move, a0 )+ a1 )+ move, a0 )+ a1 )+ move,
sp ) a0 move, ( clear the dividend operand )
0 #n a0 )+ move, 0 #n a0 )+ move, 0 #n a0 )+ move,
1 #n sp ) addq,
0 #n sp -) move, ( count number of digits )
aacum #n a0 move, ( a0 points to remainder )
( begin at left [high] end of aacum )
( shift left, find multiple, subtract from remainder )
( offset -- offset remainder+1 )
begin, 0 #n d1 moveq, ( d1 holds the digit )
a0 sp -) move, ( shift remainder, find multiple )
sp ) sp -) move, 1 bsr, 2 bsr, ( remainder -- )
1 #n sp ) addq, ( -- remainder+1 )
-1 #n d1 .w and, ne ( multiple not 0? )
if, awide #n a0 subq, a0 sp -) move, ( shift mult )
1 bsr, atemp awide + #n a0 move,
sp ) a1 move, awide #n a1 add, ( remainder )
awide 1- #n d2 moveq, ( subtract multiple from remainder )
( 00ef #n ccr and, )
23c00ef , ( turn X bit off in the condition code reg )
begin, a0 -) a1 -) sbcd, d2 nt -until,
d1 swap,
then, ( find 2nd digit, subtract multiple )
sp ) a1 move, atemp #n a0 move, awide #n d0 moveq,
begin, a1 )+ a0 )+ .b move, d0 nt -until, ( move to atemp )
2 bsr, ( find multiple )
-1 #n d1 .w and, ne ( multiple not 0? )
if, sp ) a1 move, awide #n a1 add, ( address of remainder )
awide 1- #n d2 moveq, ( subtract multiple from remainder )
23c00ef , ( 00ef #n ccr and, | turn X bit off in condition code reg )
begin, a0 -) a1 -) sbcd, d2 nt -until,
then, ( sign answer offset remainder' -- sign answer' offset' )
0 #n d2 moveq, d1 d2 .w move,
d1 swap, 4 #n d1 lsl, d1 d2 .w or, ( combine 2 digits )
sp )+ a0 move, sp )+ d0 move, sp ) a1 move,
d2 a1 )+ .b move, a1 sp ) move, ( move 2digits to answer )
1 #n d0 addq, d0 sp -) move, a0 a1 move,
awide 1- #n d1 moveq, d1 d0 cmp, ne
if, 0 #n d0 moveq,
begin, a1 )+ d0 .b or, d1 ne -until, -1 #n d1 cmp,
then, eq ( done? - dividend full or remainder zero? )
until, ( d1 contains -1 if remainder is zero )
( if remainder isn't zero, double remainder )
( sign answer offset -- sign answer offset' | 3c0010 , )
-1 #n d1 cmp, ne ( d1 contains -1 if remainder isn't zero )
lif, aacum #n sp ) add, sp ) a0 move,
awide #n a0 add, awide 2- #n d1 moveq, ( double remainder )
begin, a0 -) d0 .b move, d0 d0 abcd, d0 a0 ) .b move, d1 nt
-until, sp ) a0 move, mtable #n a1 move, awide 1- #n d2 moveq,
0 #n d0 moveq, d0 d3 move, ( a1=multiple a0=remainder )
begin, a1 )+ d3 .b move, a0 )+ d0 .b move, ( not sign ext )
d0 d3 sub, ( unsigned compare, if a1<a0 then round )
4 lt bra,
d2 gt -until,
( round if remainder*2 is greater than divisor )
( or equals divisor and last digit is odd )
-1 #n d2 .w cmp, eq ( d2=-1 if remainder = mtable )
if, i' asp a0 move, ( a0=a1 then check last digit )
awide 1- #n a0 add, a0 ) d0 .b move,
0 #n d0 btst, ne ( round if last digit is odd )
if, 4 :l ( round up by one in the last
digit )
i' asp a0 move,
awide #n a0 add, awide 2- #n d2 moveq, 0 #n d1 moveq,
( 10 #n ccr or, )
003c0010 , ( turn X bit on in condition code reg )
begin, a0 -) d0 .b move, d1 d0 abcd, d0 a0 ) .b move,
d2 nt -until,
then, then, then, ( examine overflow, place sign )
8 #n sp addq, ( discard remainder address )
i' asp a0 move, awide 1- #n d1 moveq, 0 #n d0 moveq,
begin, a0 )+ d0 .b or, d1 ne -until, d1 .b tst, mi
if, 0 #n sp ) move, ( answer is zero, force sign to zero )
then, i' asp a0 move, 0 #n d0 moveq,
a0 ) d0 .b move, ne ( d0 now holds overflow flag )
if, 08 #n a0 ) .b move, then,
sp )+ d1 move, d1 a0 ) .b move, next,
1 :l ( address -- | shift left )
sp 4 )d a0 move, sp )+ sp ) move, ( sp = return stack )
atemp #n a1 move, awide #n d0 moveq,
begin, a0 )+ a1 )+ .b move, d0 nt -until,
0 #n a1 ) .b move, atemp #n a0 move, 2 #n d3 moveq,
begin, a0 ) d0 move, 4 #n d0 lsl, ( shift left 1 nybble )
0 #n d2 moveq, a0 4 )d d2 .b move, 4 #n d2 lsr,
d2 d0 or, d0 a0 )+ move, d3 nt
-until, rts,
( compare with multiples table )
2 :l ( -- | input: a1 = multiple that is greater than remainder )
mtable #n sp -) move, ( d1 = index )
begin, atemp #n a0 move, sp ) a1 move, 0 #n d0 moveq,
d0 d3 move, awide 2/ 1- #n d2 moveq, ( a1=multiple a0=rem )
begin, a1 )+ d3 .w move, a0 )+ d0 .w move, ( unsigned cmp )
d3 d0 sub, 3 mi bra, ( if a0<a1 branch )
d2 gt -until, ( remainder =< element )
awide #n sp ) add, 1 #n d1 .w addq,
again, 3 :l ( rem>element, d1= index found, max: 9 )
sp )+ a0 move, ( a0 = multiple that is just greater )
0a #n d1 .b cmp, ge ( check for overflow after compare )
if, i' asp #n a0 move, a0 ) a0 move, 08 #n a0 ) .b move,
14 #n sp add, ( d1 = 0a means overflow )
next, then, rts, ;c
: a* ( a b == a*b )
<muls> <a*> ;
: a/ ( a b == a/b )
<muls> <a/> ;
code a% ( a == a/100 )
i' asp a0 move, awide #n a0 add,
awide 3 - #n d2 moveq, 0 #n d1 moveq,
49 #n a0 -) .b cmp, hi ( examine last 2 digits )
if, ( 10 #n ccr or, -- round up )
50 #n a0 ) .b cmp, 1 ne bra, 0 #n a0 -1 )d .b btst, ne
if, 1 :l 003c0010 , ( turn X bit on in condition code reg )
then, then,
begin, a0 -) d0 .b move, d1 d0 abcd, d0 a0 1 )d .b move,
d2 nt -until, 0 #n d0 moveq, d1 d0 abcd, d0 a0 ) .b move,
next;
code asqrt ( a == sqrt[a] )
i' asp a0 move, a0 ) .b tst, ne ( invalid operand flag set? )
if, 0c #n a0 ) .b or, next, then, ( yes, return uNaN )
i' aacum a1 move,
a0 )+ a1 )+ move, a0 )+ a1 )+ move, ( move operand to aacum )
a0 )+ a1 )+ move, 0 #n a1 )+ move,
0 #n a1 )+ move, 0 #n a1 ) move, ( pad aacum with 0's )
i' asp a0 move, 0 #n a0 )+ move, ( clear asp: answer )
0 #n a0 )+ move, 0 #n a0 ) move,
0 #n d3 moveq, ( clear d3: place )
i' aacum a0 move, 1 #n a0 addq, ( 1st 2 digits of rem - ignoring sign )
begin, a0 )+ .b tst, eq ( while digit pair is zero )
while, 1 #n d3 addq, ( increment place count )
awide 1+ #n d3 cmp, eq ( point to next digit pair )
if, next, then, again, ( operand = 0, done )
atemp #n a0 move, 2 #n a0 ) .b move, ( used to add 2 to sub )
begin, i' abuffer a0 move, 0 #n a0 )+ move,
0 #n a0 )+ move, 0 #n a0 )+ move, ( clear abuffer: subtractor )
0 #n d2 moveq, ( clear d2: choice )
i' asp a0 move, i' abuffer a1 move, ( asp -> abuffer )
3 #n d1 moveq, 0 #n d0 moveq,
begin, a0 ) a1 )+ move, a0 )+ d0 or, d1 nt -until,
0 #n a1 ) move, d0 tst, ne ( if answer not zero )
if, awide 3 + #n d0 moveq,
0ef #n ccr .b and, ( clr X bit in ccr, for abcd )
begin, a0 -) a1 -) .b abcd, d0 nt -until, ( asp*2 -> abuffer )
0 #n d3 btst, eq ( check oddness of place )
if, 10 #n a1 add, 3 #n d1 moveq, ( place = even, )
begin, a1 -) d0 move, 4 #n d0 lsr, ( shiftright 1 nybble )
d0 a1 ) move, a1 -1 )d d0 .b move,
4 #n d0 lsl, d0 a1 ) .b or, d1 nt -until,
0 #n a1 ) .b move, ( clear leading byte )
then, then,
i' abuffer a1 move, 5 #n a1 addq,
d3 d0 move, 1 #n d0 lsr,
d0 a1 add, a1 sp -) move, ( sp+4: subtractor )
1 #n a1 -) .b or, ( add 1 to subtractor )
d3 d0 move, 1 #n d0 addq, 1 #n d0 lsr,
i' aacum a0 move, d0 a0 add, a0 sp -) move, ( sp: remainder )
begin, abuffer 3 + #n a1 move, ( a1: subtractor )
sp ) a0 move, awide 1- #n d0 moveq, ( a0: remainder )
begin, a1 )+ a0 )+ .b cmp, d0 ne -until, nc
while, eq
if, 8 #n sp addq, ( sub = rem, 2drop )
1 #n d2 addq, 1 #n d3 addq, 3 bsr, ( store choice )
next, then, ( all done )
abuffer 3 + awide + #n a1 move, ( a1: subtractor )
sp ) a0 move, awide #n a0 addq, ( a0: remainder )
awide 1- #n d0 moveq,
0ef #n ccr .b and, ( clr X bit in ccr, for sbcd )
begin, a1 -) a0 -) .b sbcd, d0 nt -until,
atemp 1+ #n a0 move, sp 4 )d a1 move,
0ef #n ccr .b and, ( clr X bit in ccr, for abcd )
a0 -) a1 -) .b abcd, ( add 2 to subtractor )
1 #n d2 addq, ( increment choice )
again, 8 #n sp addq,
1 #n d3 addq, 11 #n d3 cmp, ne ( inc place )
while, 3 bsr, again,
5 #n d2 cmp, eq ( rounding )
if, 1 #n d3 addq, 1 #n d3 lsr, ( between odd and even )
i' aacum a0 move, d0 a0 add, ( a0: remainder )
0 #n d0 moveq, awide 1- #n d1 moveq,
begin, a0 )+ d0 .b or, d1 ne -until,
2 ne bra, ( more than halfway? )
i' asp a0 move, ( exactly halfway )
0 #n a0 awide 1- )d .b btst, ne ( exactly halfway above odd? )
if, 2 :l ( yes, round up )
i' atemp a0 move, 0 #n a0 )+ move,
0 #n a0 )+ move, 1 #n a0 )+ move, ( a0: temp = .0000000001 )
i' asp a1 move, awide #n a1 addq,
awide 1- #n d0 moveq,
0ef #n ccr .b and, ( clr X bit in ccr, for abcd )
begin, a0 -) a1 -) abcd, d0 nt -until,
then,
else, 2 nc bra, then, next, ( choice > 5? )
3 :l i' asp a0 move, ( store choice in asp )
d2 d0 move, ( d0: choice )
d3 d1 move, 1 #n d1 subq, 1 #n d1 lsr, nc ( offset in asp: d1+4 )
if, 4 #n d0 lsl, then, ( place = even, shift left )
d0 a0 d1 4 xw)d .b or, rts, ( store choice )
;c
code checkanswer ( -- | == a | r: -- addr | action depends on pass )
ip ) d0 .b move, 1 #n i' pass cmp, ne
if, 2 #n i' pass cmp, eq
if, 7 #n d0 btst, eq ( pass 2, check answerbit )
if, ip rp -) move, 7 #n ip ) .b bset, ( not ans, save ip, set ansbit )
awide 6 + #n ip add, next, then, ( finish word )
else, 3 #n ip ) .b bclr, ( clear discrepancy bit )
then, 6 #n ip addq, awide #n d0 moveq, ( move answer to stack )
d0 i' asp add, i' asp a1 move, 1 #n d0 subq,
begin, ip )+ a1 )+ .b move, d0 nt -until,
lelse, 7 #n ip ) .b bclr, ( pass1, clear answerbit )
i' scanner #n a0 move, ip 2 )d a1 lea, 3 #n d1 moveq,
begin, a0 )+ a1 )+ .b move, d1 nt -until, ( fill pointer field )
i' redef tst, eq
lif, 6 #n ip ) .b btst, ne ( check poppedflag )
lif, 5 #n ip ) .b bclr, ( clear autohide bit )
i' scanner a0 move, ( find surface expression )
4 #n a0 addq, a0 a1 move, ( skip calctoken )
a0 i' oldpocket move, ( for autopush )
begin, a1 )+ d0 .b move, ( skip hidden expression )
&firsthid #n d0 .b and, &firsthid #n d0 .b cmp, ne
until, 1 #n a1 subq, ( a1 = 2nd result char )
begin, a1 )+ d0 .b move, a1 )+ d1 .b move, ( d0 = reslt/surf char )
&firsthid &dln or #n d1 .b and, ( d1 = attr byte )
&dln #n d1 .b cmp, eq ( in result? )
while, a1 ) d1 .b move, &firsthid #n d1 .b and, ( skip accent? )
&firstacc #n d1 .b cmp, eq if, 1 #n a1 addq, then,
i' popsep 3 + d0 .b cmp, eq ( in result, found popsep? )
until, eq ( a1 = surface after popsep )
lif, a1 d1 move, ( popsep, MATCH SURFACE W/ HIDDEN CHARS)
a1 1 )d d0 .b move, &firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq ( dotted underlined popsep? )
lif, &calc #n a1 2 )d .b cmp, ne ( yes, calctoken? )
lif, &calc #n a1 3 )d .b cmp, ne ( no, accented calctoken? )
lif, 3 #n ip ) .b btst, 1 ne bra, ( no, discrepancy flag?)
begin, a0 )+ d0 .b move, a1 ) d2 .b move,
&firsthid #n d2 .b and, &firstacc #n d2 .b cmp, eq
if, 1 #n a1 addq, then, d0 d2 move, ( skip accents )
&firsthid #n d2 .b and, &firsthid #n d2 .b cmp, 2 ne bra,
a1 )+ d2 .b move, i' popsep 3 + d2 .b cmp, ne ( popsep?)
while, 4 #n d0 lsl, 0f #n d0 .b or, ( no, combine nybbles )
a0 )+ d0 .b and, ascii , #n d0 .b cmp, eq
if, i' commapun 3 + d0 .b move, ( 1st, translate to )
else, ascii . #n d0 .b cmp, eq ( native language )
if, i' dpoint 3 + d0 .b move, then, then,
d2 d0 .b cmp, 1 ne bra, ( compare bytes )
a1 )+ d0 .b move,
&firsthid &dln or #n d0 .b and, &dln #n d0 .b cmp, ne
until, a0 )+ d0 .b move, &firsthid #n d0 .b and,
&firsthid #n d0 .b cmp, eq ( surfac$ < hidden$ )
if, 1 :l d1 i' parsed move, ( not match, recompile )
t' autopush #n sp -) move, tc' execute jmp,
2 :l a1 1 )d d0 .b move, &firsthid #n d0 .b and,
&firstacc #n d0 .b cmp, eq
if, 1 #n a1 addq, then, ( skip accent byte )
&calc #n a1 2 )d .b cmp, ne ( next calctoken? )
if, a1 1 )d d0 .b move, ( no )
&firsthid &dln or #n d0 .b and, &dln #n d0 .b cmp, eq
if, a1 )+ d2 .b move, ( popsep? )
i' popsep 3 + d2 .b cmp, 1 ne bra, ( surf$ > hdn$ )
then, then, then, 5 #n ip ) .b bset, ( set autohide bit )
then, then, then, then, then, then, then, tc' <exit> jmp, ;c ( don't finish )
code placeanswer ( a == a | r: address -- | placeanswer in compiled word )
rp )+ a0 move, ( addr of definition )
80 #n a0 ) .b or, 6 #n a0 add, ( set answerbit, skip pointer )
i' asp a1 move, awide 1- #n d0 moveq, ( arithmetic stack pointer )
begin, a1 )+ a0 )+ .b move, d0 nt -until, ( move answer from stack )
tc' <exit> jmp, ;c ( done with word )
code #table
nx ) jsr, ;c " 1234567890" here swap dup allot move
code textify ( a == a' | -- flag | returns & inserts new value )
i' textify? tst, eq ( textify? is turned off? )
if, -1 #n i' textify? move, ( yes, turn it on, do nothing )
lelse, bp d0 move, d0 .b clr, i' lastcalc d0 add, ( from aexec )
d0 d0 .w add, d0 d0 .w add, d0 a0 move, a0 ) a0 move, ( a0 = exa )
3 #n a0 add, a0 sp -) move, ( save flagbyte addr )
0 #n d1 moveq, a0 ) d1 .b move, ( d1: bitflags )
9f #n a0 ) .b and, ( clear poppedflag & autohide bits )
0 #n i' commas move, 4 #n d1 btst, ne ( TEST COMMABIT )
if, 10 #n i' commas move, then, ( store in commaflag1 )
i' scanner a0 move, ( scanner points to text to be moved )
i' mover a1 move, a1 -2 )d d2 .b move, ( accented first char? )
&firsthid #n d2 .b and, &firstacc #n d2 .b cmp, eq
if, a1 -) a1 -1 )d .b move, then, ( yes, discard accent byte )
a1 -3 )d d2 .b move, a1 sp -) move, ( save text addr )
i' oldpuns 3 + d2 .b cmp, eq ( decimal point? )
if, 0 #n d0 moveq,
else, 80000001 #n d0 move, ( d0: init precision )
ascii - #n d2 .b cmp, eq
if, 1 #n d0 subq, ( ignore minus sign )
then, then, 3 #n d3 moveq, ( copy four bytes of )
begin, a0 )+ a1 )+ .b move, d3 nt -until, ( encoded calctoken )
5 #n d1 bclr, ne ( test autohide bit )
if, a0 sp -) move, i' popsep 3 + d3 .b move, ( HIDE SURFACE TEXT )
begin, a0 )+ d3 .b cmp, eq until,
1 #n a0 addq, ( a0 = 1st expr char )
begin, a0 )+ d1 .b move, d1 d2 .b move, ( char = accent? )
&firsthid #n d2 .b and, &firstacc #n d2 .b cmp, eq
if, a0 )+ d1 .b move, then, ( yes, skip accent )
d1 d3 .b cmp, ne ( no, byte = popsep? )
while, a0 )+ d2 .b move, ( no, consecutive byte = attr? )
&firsthid &dln or #n d2 .b and, &dln #n d2 .b cmp, eq
while, &calc #n a0 ) .b cmp, ne ( adjacent calctoken? )
while, i' commapun 3 + d1 .b cmp, eq ( yes, hide expr character )
if, ascii , #n d1 .b moveq, ( but first translate from )
else, i' dpoint 3 + d1 .b cmp, eq ( native language to )
if, ascii . #n d1 .b moveq, then, then, ( universal )
d1 d2 .b move, 4 #n d2 lsr, ( transform to hidden format )
&firsthid #n d2 .b or, d2 a1 )+ .b move,
&firsthid #n d1 .b or, d1 a1 )+ .b move,
again, sp )+ a0 move,
begin, a0 )+ d1 .b move, &firsthid #n d1 .b and,
&firsthid #n d1 .b cmp, ne until, ( discard old hidden text )
else,
begin, a0 )+ d1 .b move, ( COPY HIDDEN TEXT )
d1 d2 .b move, &firsthid #n d2 .b and, &firsthid #n d2 .b cmp, eq
while, d1 a1 )+ .b move,
again,
then, a1 i' mover move, ( SCAN OLD PRECISION: )
begin, 0 #n d2 moveq, a0 -1 )d d2 .b move, ( d2 = last char )
d2 d3 .b move, &firsthid #n d3 .b and, &firstacc #n d3 .b cmp, eq
if, a0 )+ d2 .b move, ( skip accent )
then, a0 ) d1 .b move,
&firsthid &dln or #n d1 .b and, ( discard old result and find
punctuation )
&dln #n d1 .b cmp, eq ( in result? )
lif, markerchar #n d2 .b cmp, eq ( yes, w/ markerchar? )
if, &calc #n a0 1 )d .b cmp, ( yes, w/ calctoken byte? )
4 eq bra, ( placemarker, ->4 )
then, i' oldpuns 2+ d2 .b cmp, 3 eq bra, ( result has commas, ->3 )
i' popsep 3 + d2 .b cmp, eq ( popped separator? )
if,
begin, a0 1 )d d1 .b move, ( yes, SKIP REST OF CHARS )
&firsthid #n d1 .b and, &firstacc #n d1 .b cmp, eq
if, 1 #n a0 addq, then,
2 #n a0 addq, a0 ) d2 .b move,
&firsthid &dln or #n d2 .b and, &dln #n d2 .b cmp, ne
if, &calc #n a0 -1 )d .b cmp, eq
if, 1 #n d0 addq, then, ( easier this way ... )
4 bra, then,
again,
then, i' oldpuns 3 + d2 .b cmp, eq ( found decimal point? )
if, d0 tst, mi ( yes, first one? )
if, 4 #n d0 sub, mi ( yes, room for commas? )
if, i' commas .b tst, eq ( yes, commaflag2 clear? )
if, 0 #n i' commas 3 + .b move, ( yes, clr commaflag1 )
then, then, then, 0 #n d0 moveq, ( found dp, clr precision )
else, ascii ? #n d2 .b cmp, ne ( check for ?'s )
if, i' #chars d1 move, 1 #n d1 subq, ( check for valid digit )
t' #table +ttable a1 move, 2 #n a1 addq, ( digit table addr )
begin, a1 )+ d2 .b cmp, d1 eq -until, ( char is "?" or digit? )
4 ne bra, ( no, -> 4 )
then, 1 #n d0 addq, ( yes, incr precision )
then,
else, i' oldpuns 2+ d2 .b cmp, 4 ne bra, ( not in result, no comma ->4 )
a0 1 )d d1 .b move, ( comma, nextchar inresult? )
&firsthid &dln or #n d1 .b and,
&dln #n d1 .b cmp, 4 ne bra, ( no, not edited comma, ->4 )
a0 2 )d d1 .b move,
&firsthid #n d1 .b and, &firstacc #n d1 .b cmp, eq
if, 1 #n a0 addq, then, ( another accent in the way )
&calc #n a0 2 )d .b cmp, 4 eq bra, ( another result, -> 4 )
1 #n a0 addq, ( skip edited comma )
3 :l 1 #n i' commas .b move, ( 3:: set commaflag2 )
then, 2 #n a0 addq, ( skip to next char )
again,
4 :l ( PAST RESULT, SCAN EDITED PRECISION,
SET PRECIS )
&calc #n a0 -) .b cmp, ne ( calctoken? )
lif, 0 #n d2 moveq, ( no, scan edited precision )
begin, begin, begin, a0 )+ d2 .b move, ( d2 = this char )
d2 d1 move, &firsthid &dln or #n d1 .b and,
&dln #n d1 .b cmp, ne ( d1 = attribute? )
until, &firsthid #n d1 .b and, ( no, d1 = accent? )
&firstacc #n d1 .b cmp, ne
until, i' oldpuns 3 + d2 .b cmp, ne ( no, d2 = dp? )
if, 1 #n d0 addq, ( no, inc precision count )
ascii 0 #n d2 .b cmp, ( d2 = 0? )
5 ne bra, a0 -2 )d d1 .b move, ( no, done, -> 5 )
i' oldpuns 2+ d1 .b cmp, eq ( prev digit = comma? )
if, 1 #n i' commas .b move, ( set commaflag2 )
else, i' oldpuns 3 + d1 .b cmp, eq ( prev digit = dp? )
if, d0 d2 move, mi ( 1st dp? )
if, 1 #n d0 moveq, ( yes, clear precision )
5 #n d2 sub, mi ( room for commas? )
if, i' commas .b tst, eq ( yes, commas? )
if, 0 #n i' commas 3 + .b move, ( no, clr cmaflg1 )
then, then, then, then, then, then,
again, 5 :l ( NO MORE EDITED DIGITS )
a0 -2 )d d1 .b move, i' oldpuns 3 + d1 .b cmp, ne ( dp? )
if, 1 #n a0 addq, then, ( yes, adjust )
then, 2 #n a0 subq, 1 #n d0 subq, ( a0 -> nondigit, dec precis )
d0 d2 move, mi ( dp found? )
if, 0 #n d0 moveq, ( no, clear precision )
4 #n d2 sub, mi ( room for commas? )
if, i' commas .b tst, eq ( yes, commas found? )
if, 0 #n i' commas 3 + .b move, ( no, clear commaflag1 )
then, then,
else, awhole 2- #n d0 cmp, gt
if, awhole 2- #n d0 moveq, then, ( max # frac digits )
then, a0 1 )d d1 .b move, a0 2 )d d2 .b move,
&firsthid #n d1 .b and, &firstacc #n d1 .b cmp, eq
if, 1 #n a0 subq, then, ( accented char )
&calc #n d2 .b cmp, eq ( calctoken? )
if, markerchar #n a0 ) .b cmp, ne ( but not placemarker? )
if, tb #n a0 -) .b move, then, then, ( yes, INSERT TAB )
( UNPACK ANSWER, W/ DP )
a0 i' scanner move, d0 i' precis move, ( set scanner, precis )
i' asp a0 move, awide #n i' asp sub, ( digits will go to aacum )
aacum #n a1 move, 0 #n d3 moveq, d3 d1 move,
a0 )+ d3 .b move, 3 #n d3 btst, eq ( d3 holds tag bits )
lif, awide 1- #n d0 moveq, ( not a NaN )
begin, a0 )+ d1 .b move, d1 d2 move, 4 #n d2 lsr,
30 #n d2 or, d2 a1 )+ .b move, 0f #n d1 and,
30 #n d1 or, d1 a1 )+ .b move, awhole 2/ #n d0 cmp, eq
if, i' dpoint 3 + a1 )+ .b move, ( transfer digits to aacum )
then, d0 nt -until, i' precis d1 move, ( round to precis frac digits )
1 #n d1 addq, aacum awide + #n a1 move, d1 a1 add, ( round )
a1 sp -) move, ( free up register )
34 #n a1 ) .b cmp, gt ( 1st truncated digit > 34? )
lif, ( 35 #n a1 ]+ .b cmp, eq ( yes, = 35? ]
if, awide 2* awhole - #n d0 moveq, ( yes, now check ]
d1 d0 sub, 1 #n d0 subq, ( remaining fractional digits ]
begin, 30 #n a1 ]+ .b cmp, d0 ne -until, ( eq ( = 30? ]
if, sp ] a1 move, i' precis tst, eq ( last good dgt odd? ]
if, 1 #n a1 subq, then, 0 #n a1 -1 ]d .b btst, then,
then, ne ( >500, elim: =500 & odd ]
if, ) d1 d0 move, awhole 1- #n d0 add, 0 #n d1 moveq, ( round )
sp ) a1 move, atemp #n a0 move, 31313131 #n a0 ) move,
a0 )+ a0 ) move, a0 )+ a0 ) move, ( add 31 and carry )
begin, a1 -1 )d d2 .b move,
i' oldpuns 3 + d2 .b cmp, eq ( skip dp? )
if, 1 #n a1 subq, 4 #n a0 add, d0 d0 move,
else, a0 -) a1 -) .b abcd, a1 ) d1 .b move, ( add )
0f #n a1 ) .b and, 30 #n a1 ) .b or, ( fix high nyb )
70 #n d1 .b and, 60 #n d1 .b cmp, then, ( carry? )
d0 eq -until, -1 #n d0 .b cmp, eq ( no carry, overflw? )
if, 4 #n sp addq, 8 #n d3 moveq, 6 bra, ( new tag bit )
then, then, ( then,) 4 #n sp addq, ( drop )
i' precis d1 move, ne if, 1 #n d1 addq, ( no trailing dp )
then, then, 6 :l
aacum #n a1 move, awhole #n d0 moveq,
begin, 30 #n a1 )+ .b cmp, d0 ne -until, ( count # of whole digits )
sp )+ a0 move, 2 #n a0 subq, ( a0 -> first digit )
a0 ) d2 .b move, ( get attribute byte )
3 #n d3 btst, ne ( check for NaN )
if, 4 #n d3 and, eq ( display NaN errors with dotted
underline )
if, ascii > #n a0 -) .b move, ( overflow NaN symbol )
else, ascii ? #n a0 -) .b move, ( undefined NaN symbol )
then, i' mover a0 move,
i' commas tst, ne ( insert commas? )
if, i' commapun 3 + a0 )+ .b move, d2 a0 )+ .b move, then,
2 #n d3 moveq, ascii ? #n d0 moveq, ( place two question marks )
begin, d0 a0 )+ .b move, d2 a0 )+ .b move, d3 nt -until,
i' precis d1 move, ne
if, 1 #n d1 subq, ( place decimal point )
i' dpoint 3 + a0 )+ .b move, d2 a0 )+ .b move,
begin, d0 a0 )+ .b move, d2 a0 )+ .b move, d1 nt -until,
then, a0 i' mover move, ( new mover )
( display answer with dotted underline )
lelse, aacum awhole + #n a1 move, d0 a1 sub, ( from aacum )
d0 d1 add, eq ( unsigned zero )
if, 30 #n a0 -) .b move, ( answer is zero )
else, 0 #n d3 btst, ne ( sign flag )
if, ascii - #n a0 -) .b move, 1 #n d1 addq, ( neg # )
else, a1 )+ a0 -) .b move, 0 #n d3 moveq, ( pos # )
then, 2 #n d1 subq, pl if, i' mover a0 move,
begin, i' commas tst, ne if, d3 tst, eq
if, 1 #n d0 subq, 3 #n d0 cmp, 7 eq bra, 6 #n d0 cmp,
7 eq bra, 9 #n d0 cmp, eq if, 7 :l ( comma )
i' commapun 3 + a0 )+ .b move, d2 a0 )+ .b move,
then, then, 0 #n d3 moveq, ( move digits to mover )
then, a1 )+ a0 )+ .b move, d2 a0 )+ .b move, d1 nt -until,
a0 i' mover move,
then, then, then, sp )+ a0 move, ( get flagbyte )
i' commas tst, ne ( needed commas? )
if, 4 #n a0 ) .b bset, ( yes, set commabit in def )
else, 4 #n a0 ) .b bclr, then, then, ;c ( no, clear commabit in def )
code tscan ( -- flag | == a | move gap & execute next calctoken )
0 #n sp -) move, i' scanner a1 move, i' mover a0 move,
a1 d0 move, 30 #n d0 sub, d0 a0 cmp, pl ( max growth=30 )
if, t' noroomcalc #n sp -) move, tc' execute jmp, ( exit, not enough room)
1 :l a1 )+ a0 )+ .b move, ( move byte preceding, )
2 :l a1 )+ a0 )+ .b move, ( move locked calc pocket & result )
begin, a1 )+ d0 .b move, d0 a0 )+ .b move, ( move pocket )
&firsthid #n d0 .b and, &firsthid #n d0 .b cmp, ne until,
begin, a1 )+ d0 .b move, d0 a0 )+ .b move, ( move result )
&firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq ( dotted underline? )
while, &lockedcalc #n a1 ) .b cmp, 2 eq bra, ( locked calc )
a1 )+ d0 .b move, d0 a0 )+ .b move,
&calc #n d0 .b cmp, 3 eq bra, ( exit, calctoken follows dln )
&firsthid #n d0 .b and, &firstacc #n d0 .b cmp, eq
if, a1 )+ a0 )+ .b move, then, ( moved accent, now move digit )
again, then,
begin, begin,
a1 )+ d0 .b move, d0 a0 )+ .b move, ( move text to gap til token )
&firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq ( dotted underline? )
until, &calc #n a1 ) .b cmp, eq ( calctoken follows dln, exit )
if, a1 )+ a0 )+ .b move, 3 bra, then,
&calc #n a1 1 )d .b cmp, eq ( exit, calctoken follows accent )
if, a1 )+ a0 )+ .b move, a1 )+ a0 )+ .b move, 3 bra, then,
&lockedcalc #n a1 ) .b cmp, 2 eq bra,
&lockedcalc #n a1 1 )d .b cmp, 1 eq bra,
a0 -1 )d d0 .b move, 3 #n d0 btst, ne ( dotted underline? )
if, d0 d1 .b move, ( yes, strip from orphan )
3 #n d1 .b and, ne ( other attributes? )
if, 0eb #n d0 .b and, d0 a0 -1 )d .b move, ( clear dln bit )
else, 1 #n a0 subq, 4 bsr, ( remove dln byte )
then, then, ( ignore locked calctoken = 0e5 )
again, 3 :l a0 i' mover move, a1 i' scanner move, ( update scanner )
i' eot a1 cmp, nc
if, -1 #n sp ) move, next, ( done = past eot )
4 :l a0 i' oldeos move, ( subr = min killivls )
i' oldbos tst, eq if, a0 i' oldbos move, then, rts,
then, tc' ^prevchar jsr, 4 bsr, ;c
code aexec ( flag -- flag' | == a | exec calctoken at scanner )
i' astack i' asp move, ( clear arith stack )
0 #n i' redef move, ( clear redef flag )
i' scanner a0 move, ( addr of calctoken )
3 #n d1 moveq, 0 #n d0 moveq, ( encoded token = 4 bytes )
begin, 8 #n d0 lsl, a0 )+ d0 .b move, d1 nt ( get encoded token )
-until, d0 d1 move, ( decode token )
0000000F #n d0 and, 4 #n d1 lsr, 00F0F0F0 #n d1 and, d1 d0 or,
000000FF #n d0 and, 4 #n d1 lsr, 000F0F00 #n d1 and, d1 d0 or,
00000FFF #n d0 and, 4 #n d1 lsr, 0000F000 #n d1 and, d1 d0 or,
d0 i' lastcalc move, i' system.status a1 move,
a1 inptr )d d1 .w move, a1 outptr )d d1 .w cmp, ne
if, -1 #n sp ) move, then,
d0 sp -) move, tc' execute jmp, ;c ( execute token )
code ascan1 ( -- flag | for Boyer-Moore pass 1 )
0 #n sp -) move, i' scanner a0 move, 6 #n d2 moveq,
&firsthid 101 - #n d1 moveq,
begin, 1 #n a0 addq,
begin, d2 a0 add, a0 ) d1 .b cmp, cs ( scan to calctoken )
until, a0 a1 move, 5 #n d0 moveq, &calc 100 - #n d3 .b moveq,
begin, a1 -) d3 .b cmp, d0 eq -until, ne
while, a0 a1 move, 5 #n d0 moveq, &lockedcalc 100 - #n d3 .b moveq,
begin, a1 -) d3 .b cmp, d0 eq -until, eq
until, 1 #n a1 addq, a1 i' scanner move,
i' eot a1 cmp, mi ( past end? )
if, tc' aexec jmp, then,
-1 #n sp ) move, next;
code ascan2 ( -- flag | for Boyer-Moore pass 2 )
0 #n sp -) move, i' scanner a0 move, 6 #n d2 moveq,
&firsthid 101 - #n d1 moveq, &calc 100 - #n d3 moveq,
begin, 1 #n a0 addq,
begin, d2 a0 add, a0 ) d1 .b cmp, cs ( scan to calctoken )
until, a0 a1 move, 5 #n d0 moveq,
begin, a1 -) d3 .b cmp, d0 eq -until, eq
until, 1 #n a1 addq, a1 i' scanner move,
i' eot a1 cmp, mi ( past end? )
if, tc' aexec jmp, then,
-1 #n sp ) move, next;
code findmarker ( addr -- addr' | Boyer-Moore version )
&firsthid 101 - #n d1 moveq, &calc 100 - #n d2 moveq,
6 #n d3 moveq, sp ) a0 move, tc' ^prevchar jsr, a0 a1 move,
begin, a1 a0 move, tc' ^nextchar jsr, a0 a1 move,
begin, d3 a1 add, a1 ) d1 .b cmp, cs
until, a1 a0 move, 5 #n d0 moveq,
begin, a0 -) d2 .b cmp, d0 eq -until, eq ( scan to calctoken )
if, tc' ^prevchar jsr, markerchar #n a0 ) .b cmp,
then, eq
until, a0 sp ) move, next;
code aencode ( token -- atoken )
sp 2 )d d0 .b move, d0 sp 1 )d .b move, 4 #n d0 .b lsr, d0 sp ) .b move,
sp 3 )d d0 .b move, 4 #n d0 .b lsr, d0 sp 2 )d .b move,
f0f0f0f0 #n sp ) or, next;
code adecode ( atoken -- token )
0f0f0f0f #n sp ) and, sp 2 )d d0 .b move, 4 #n d0 .b lsl,
d0 sp 3 )d .b or, sp 1 )d sp 2 )d .b move, sp ) d0 .b move,
4 #n d0 .b lsl, d0 sp 2 )d .b or, 0 #n sp ) .w move, next;
code justmovetext ( addr -- )
sp ) a0 move, i' gap a0 cmp, lt
if, i' gap d1 move, a0 d1 sub, ( below gap, d1 = length )
d1 i' beot sub, a0 i' gap move,
tc' ^prevchar jsr, a0 i' bos move, ( ^prevchar changes a0 )
i' beot sp -) move, ( arg for move )
else, i' beot a0 cmp, le ( bug c551 )
if, i' op i' pop move, i' bos i' op move, ( inside gap, trade pointers )
i' gap a0 move, tc' ^prevchar jsr, ( deselect )
a0 i' bos move, 4 #n sp addq, next, ( clear stack, NOT MOVE )
then, a0 d1 move, i' beot d1 sub, ( above gap, d1 = length )
i' beot sp ) move, i' gap sp -) move,
a0 i' beot move, d1 i' gap add,
a0 d2 move, tc' ^prevchar jsr,
d2 a0 sub, i' gap a0 add, a0 i' bos move,
then, d1 sp -) move, i' beot a0 move, a0 i' eos move,
4 #n a0 sub, a0 i' bou move, tc' move jmp, ;c
code encalc ( # -- 3bytes | digit-attribute-calcmarker, lowbyte=0 )
sp 3 )d sp ) .b move, &dln #n sp 1 )d .b move,
&calc #n sp 2 )d .b move, 0 #n sp 3 )d .b move, next;
: ?arithmetic ( token -- addr flag )
exa 2+ dup c@ ['] checkanswer = ;
: placemarker ( -- )
pass 3 = ( only during pass3 )
if scanner nextchar scanner to ( remove marker from text )
mover prevchar mover to
mover marker to textify? off then ; ( store addr in marker )
: prescan ( # -- ) pass to scanbot scanner to ;
: panicmaybe? ( -- flag | true means scanned past end of text )
scanner eot > ?dup 0= if ?panic
if calcinterrupted? on aftercalc gap prevchar bos to ( testing
"background recalc" )
showcalc notcalculated error abort then 0 then ;
: needsglobal? ( -- )
bot bor <> eot eor <> or
if beot inresult?
if beot pastresult eos to movegap then ( always move cursor )
gap prevchar bos to 1 cstate to ( collapse widecursor, the hard way )
needsglobal error abort
then ;
: precalc ( -- length | install placemarker, move gap to bot )
needsglobal?
local oeos marker off textify? on ( init pointer and flag )
showmove? off ( needtext and needforth won't display )
badcalc? off ( only textify sets this int )
gap prevchar inresult?
if beot pastresult eos to movegap then ( so calc marker not cleave results )
eos oeos to beot partknown
-9 beot +to markerchar encalc beot ! ( place markerchar )
['] placemarker aencode beot 3 + ! ( put encoded placemarker )
markerchar hidebyte beot 7 + w! ( push a markerchar )
preset bot nextchar eos to movegap ( move gap to bottom )
preset ( so sum and relatives work )
clearundo ( so move&adjusttext will work )
gap mover to oeos eos to beot scanbot to ; ( prepare scan pointers )
: aftercalc ( -- | move gap to old position, reset all pointers )
marker
if scanner beot to mover gap to ( found marker )
marker mover <
if marker justmovetext ( marker must be below gap )
else marker mover <>
if 57 aerror# to ( major problem if it isn't )
" lost the cursor" error then then
else pass 3 =
if scanner else scanbot then ( interrupted before pass 3 )
beot to mover gap to ( prepare for move text )
beot eot <
if beot else bot then ( look for markerchar in text )
preset findmarker justmovetext 9 beot +to ( discard placemarker )
then beot eos to clearundo ( restore eos and bou )
gap prevchar dup prevcalc?
if drop mover prevchar then op to ( so autoselect won't crash )
commapun swab dpoint + oldpuns to ; ( save current punctuation )
: showaftercalc ( addr -- )
rewindow visible?
if refresh else new-display then ( ensure cursor is on screen )
gap prevchar bos = if widecursor else extendedcursor
then forceop on ;
: <showcalc> ( -- | display results )
showmove? on ( needforth & needtext will display )
( oldeos ?dup
if prevchar nextchar pastresult dup beot max partknown
else eot 1+ then oldbos ?dup 0=
if bot 1+ then swap )
bot eot 1+ killivls ;
: showcalc ( -- | display results )
<showcalc> gap showaftercalc ;
: recalc ( -- | execute and display all calctokens )
preset 14 needtext ( enough room? )
if precalc ( yes, install placemarker, move gap to start )
1 prescan begin begin ascan1 until ( pass 1 )
panicmaybe? until
2 prescan begin begin ascan2 until ( pass 2 )
panicmaybe? until
3 prescan tscan dup ( pass 3 )
if drop panicmaybe? then 0= ( catch a rare interruption )
if begin begin textify until
panicmaybe? until
then aftercalc badcalc?
if <showcalc> rewindow recalc
else showcalc then ( restore cursor, disp text )
else drop noroomcalc ( no room explain message )
gap prevchar bos to bos showaftercalc then ;
code alit ( == a )
ip sp -) move, awide #n ip add, ;c ( -- addr \ of lit in compiled def )
code a@ ( addr -- | == a )
sp )+ a1 move, i' asp #n a0 move, awide #n a0 ) add, a0 ) a0 move,
a0 d0 move, awide 2* #n d0 add,
rp d0 cmp, gt ( enough room on astack? *** )
if, t' noroomcalc #n sp -) move, ( no *** )
tc' execute jmp, ( jump to error handler *** )
then, awide 1- #n d0 moveq, ( move 12 bytes from addr to stack )
begin, a1 )+ a0 )+ .b move, d0 nt -until, next;
code a! ( addr -- | a == )
sp )+ a1 move, i' asp #n a0 move, a0 d1 move, a0 ) a0 move,
awide 1- #n d0 moveq, ( move 12 bytes from stack to addr )
begin, a0 )+ a1 )+ .b move, d0 nt -until,
d1 a0 move, awide #n a0 ) sub, next;
: a,
here awide allot a! ;
code inresult? ( addr -- flag | is next byte dotted underline attr? )
sp ) a0 move, 0 #n sp ) move, a0 1 )d d0 .b move,
&firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq ( dotted underline attr? )
if, -1 #n sp ) move, then, next; ( yes, return -1 )
: remove-word ( token -- )
dup eta if <behead> then ( remove head, then body )
dup <becode> recycle ; ( point token to abort )
: remove-body ( addr token -- )
local refs
swap 1+ w@ 1- 17ff and dup refs to ( propagate commabit, refs cnt )
07ff and ( strip commabit, ref count 0? )
if dup <becode> ( no, remove body )
align here swap +table ! 4ed3 w, ( redefine body )
compile forwarderror refs w, ( error handler, count )
else remove-word then ; ( remove word )
code -reftokens
nx ) jsr, ;c t' alit w, awide 1+ w,
t' lit w, 5 w,
t' wlit w, 3 w,
t' blit w, 2 w,
code -ref? ( count addr1 token addr2 flag -- [token] count['] addr1'|0 )
sp )+ d0 move, sp )+ a0 move, sp )+ d1 move, d0 tst, ne
if, 1 #n a0 2 )d .b subq, cs ( ref- )
if, 1 #n a0 1 )d .b subq, then, ( the only way? )
else, a0 )+ d2 .b move,
t' forwarderror #n d2 .b cmp, eq ( forward ref? )
if, 1 #n a0 1 )d .b subq, cs ( yes, dec ref count )
if, 1 #n a0 ) .b subq, ( both ref bytes )
else, eq
if, a0 ) .b tst, eq ( ref = 0? )
if, sp ) sp -) move, sp 8 )d sp 4 )d move, ( yes )
d1 sp 8 )d move, 1 #n sp 4 )d addq, ( save token )
then, then, then,
else, t' placeanswer #n d1 cmp, eq
if, 0 #n sp ) move, next, ( done, clear flag )
else, i' #reftokens d0 move, 1 #n d0 subq,
tc' -reftokens #n a1 move, ( lookup table )
begin, 2 #n a1 addq, a1 )+ d1 .w cmp, eq ( find token? )
if, a1 ) d0 .w move, d0 sp ) add, next, then,
d0 nt -until,
then, then, then, 0ff00 #n d1 and, ne ( 2 byte token? )
if, ( yes ) 1 #n sp ) addq, then, 1 #n sp ) addq, next;
: <<-refs>> ( token -- | dec refs to word with token )
?arithmetic ( right kind? )
if dup awide + 7 + 0 swap ( skip answer, init ref[s] )
begin dup w@ dup 8 shr ['] intf >
if 8 shr then ( 1 byte token )
dup ?arithmetic ( ref begins w/ checkanswer? )
-ref? dup 0= ( decrement this ref )
until drop ?dup
if 0 do remove-word loop then ( remove words w/ no refs )
then drop ;
: <-refs> ( token -- | remove word from current voc )
dup <<-refs>> dup ?arithmetic if over remove-body 0 then 2drop ;
: -refs ( token -- | remove from arithmetic voc )
?dup if current >r ['] arithmetic <addto> <-refs> r> <addto> then ;
: showselen ( -- )
gap prevchar c@ popsep =
if gap prevchar eos to movegap then
selen 1 <
if gap prevchar bos to
else gap selen 0 do prevchar loop eos to
movegap gap prevchar bos to then ; ( what if ivl table killed? )
: showredef ( -- | pop copied expression, remove marker )
scanbot beot to mover gap to ( set pointers for justmovetext )
preset beot findmarker marker to
marker eos to pass 3 =
if eos justmovetext 9 beot +to ( discard placemarker )
scanner nextchar ( addr of bad expr )
dup marker < if scanbot - mover + then
pastresult justmovetext ( move to end of bad expr )
bot eot 1+ killivls
else movegap beot dup 9 + killivls 9 beot +to beot partknown
scanner nextchar pastresult eos to movegap
then clearundo redefpopped ( already popped? )
if beot showselen prevchar op to ( cursor on obstacle )
rewindow display narrowcursor
else showpocket then ; ( pop expression )
: createrror ( error# -- | handle errors before compilation )
aerror# to sp!
oldvoc <addto> ( restore old voc )
clearundo ( in case of prepush or redefinerror )
redef if showredef ( redefinerror or autopush )
else parsed gap <>
if parsed 1+ prevchar justmovetext ( prepare cursor )
else gap prevchar bos to
then bot eot 1+ killivls gap showaftercalc
then abort ;
: compilerror ( error# -- )
compile placeanswer lasttok <-refs> createrror ;
: syntaxerror ( error# -- | handle compilation errors )
syntaxerr error compilerror ; ( prepare explain screen )
: digitserror ( error# -- | nondestructive errors )
aerror# to extradigits error ;
: noroomcalc ( -- )
29 aerror# to noroom error pass
if aftercalc showcalc abort then ;
: noroomcalc? ( needed -- )
needtext 0= if noroomcalc abort then ;
: unop adrop adrop uNaN ;
code op+tokens
nx ) jsr, ;c
ascii + c, t' a+ w, ascii < c, t' a< w, ascii & c, t' a& w,
ascii - c, t' a- w, ascii > c, t' a> w, ascii | c, t' a| w,
ascii * c, t' a* w, ascii = c, t' a= w, ascii \ c, t' unop w,
ascii / c, t' a/ w, ascii ^ c, t' unop w, ascii % c, t' a% w,
code optable
nx ) jsr, ;c tb c, ds c, pb c, rtn c, popsep c, e0 c, ( breaks )
" ;+*-/^=><&|\~)% :([" here swap dup allot move ( includes perm spc** )
here target - tc' optable 2+ -
tromaddr' opchars ! ( number of operator chars )
code <preparse> ( )
0 #n d1 moveq, d0 tst, 1 eq bra,
begin, begin,
a0 )+ d1 .b move, spc #n d1 .b cmp, ( skip space )
d0 ne -until, 93 #n d1 .b cmp, ( skip perm space )
d0 ne -until, d0 .w tst, le
if, 0 #n d0 moveq, d0 d1 move, rts, then, ( selection exhausted )
1 #n d0 subq, i' opchars d2 move, 1 #n d2 subq,
t' optable +ttable a1 move, 2 #n a1 addq,
begin, a1 )+ d1 .b cmp, d2 eq -until, 1 eq bra, ( operator char? )
a0 i' astring move, 1 #n i' astring subq, 0 #n d3 moveq,
i' commapun 3 + d1 .b cmp, 2 eq bra, ( comma -> 2 )
i' dpoint 3 + d1 .b cmp, eq ( dp? )
if, 0 #n i' aintlen move, 2 bra, then, ( yes, clear intlen -> 2 )
i' #chars d2 move, 1 #n d2 subq, ( not comma nor dp )
t' #table +ttable a1 move, 2 #n a1 addq, ( digit table addr )
begin, a1 )+ d1 .b cmp, d2 eq -until, eq
if, -1 #n i' aintlen move, 1 #n d3 moveq, ( number, not comma nor dp )
2 :l d0 tst, ne ( more selection? )
if, begin, a0 )+ d1 .b move, i' dpoint d1 cmp, eq ( yes, dp? )
if, d3 i' aintlen move, 0 #n d2 moveq, ( yes, clear ne flag )
else, i' commapun d1 cmp, ne ( and not a comma? )
if, i' #chars d2 move, 1 #n d2 subq, 1 #n d3 addq, ( yes )
t' #table +ttable a1 move, 2 #n a1 addq,
begin, a1 )+ d1 .b cmp, d2 eq -until, ( digit? )
then, then,
d0 ne -until, 1 #n d3 subq, d0 .w tst, mi
if, 0 #n d0 moveq, then, ( past end of select )
then, -1 #n d1 moveq, ( flag = -1 )
else, ( name until: operator, blank, closing paren, or end of selection )
1 #n d3 moveq, d0 tst, pl ( ?BUG? no test for 31 char max )
if, 1 #n d3 subq, ( still more in select )
begin, a0 )+ d1 .b move, 1 #n d3 addq,
t' optable +ttable a1 move, 2 #n a1 addq,
i' opchars d2 move, 1 #n d2 subq, ( name w/ "[" ok )
begin, a1 )+ d1 .b cmp, d2 eq -until, ( find end of name )
d0 eq -until, ascii : #n d1 .b cmp, eq
if, -3 #n d1 moveq, 1 #n a0 addq, 1 #n d0 subq,
else, -2 #n d1 moveq, ( flag -2 or -3 )
then, d0 .w tst, mi if, 0 #n d0 moveq, then,
then, then, 1 #n a0 subq, d3 i' alen move,
1 :l rts, ;c
code parsenext ( -- char )
i' parsed a0 move, i' selen d0 move,
t' <preparse> +ttable a1 move, a1 ) jsr,
a0 i' parsed move, d0 i' selen move,
d1 sp -) move, next;
code preparse ( addr count -- char )
sp )+ d0 move, sp )+ a0 move,
t' <preparse> +ttable a1 move, a1 ) jsr,
d1 sp -) move, next;
code ignoretable ( ignorable chars while converting to arithmetic stack )
nx ) jsr, ;c ( including perm space, BUT NOT CARRIAGE RETURN NOR TAB ** )
" abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ#$%+/>@|[\{~ <-("
swap over here swap dup allot move
tromaddr' #ignorable ! ( number of ignorable chars )
( : k anew [compile] " drop packstring . asp 10 dump cr a. ; debugging word )
( : kk pad 20 + mover to [compile] " drop packstring .s 10 - 20 dump cr over
- .s dump ; )
code sepchars nx ) jsr, ;c ( )
here tb c, ds c, pb c, rtn c, popsep c, ascii ; c, ascii ) c,
93 c, e0 c, 0 c,
here swap - tromaddr' #sepchars ! ( number of separator chars )
code packstring ( addr -- flag | == a | convert string to stack )
a2 rp -) move, 0 #n rp -) move, ( a2= temp, rp= sign )
i' mover a1 move, 4 #n a1 addq, ( a1= buffer addr )
sp ) a0 move, a0 ) d0 .b move, ( a0= string to convert )
begin, t' ignoretable +ttable a2 move, 2 #n a2 addq,
i' #ignorable d2 move, 1 #n d2 subq, 4 bsr, eq ( ignorable char? )
while, 3 #n d2 .w cmp, mi ( yes, minus sign or paren? )
if, rp ) tst, eq ( yes, change sign )
if, -1 #n rp ) move, else, 0 #n rp ) move, then, then,
d0 a1 )+ .b move, tc' ^nextchar jsr, ( copy ignorable char )
again, a1 sp ) move, -1 #n d1 moveq, ( 1st nonignorable, d1= intlen )
begin, markerchar #n d0 .b cmp, eq ( d0= char )
if, &calc #n a0 2 )d .b cmp, 1 ne bra, ( not plcmarker -> 1 )
else, i' dpoint 3 + d0 .b cmp, eq ( decimal point? )
if, d1 tst, mi ( yes, already saved? )
if, a1 d1 move, then, ( no, save position of dp )
else, i' commapun 3 + d0 .b cmp, ne ( no, char is comma? )
if, 3 bsr, 1 ne bra, ( no digits ->1 )
d0 a1 )+ .b move, ( digit, copy to buffer )
then, then, then, tc' ^nextchar jsr, ( go to next digit )
again, 1 :l rp 4 )d a2 move, rp )+ rp ) move, ( restore a2 )
20 #n a1 ) .b move, ( pad buffer w/ trailing blank )
sp ) d3 move, d3 a1 sub, 0 #n a1 cmp, eq ( d3= string buffer addr )
if, rp )+ sp ) move, a1 sp ) move, ( not number/don't pack )
t' uNaN #n sp -) move, ( place an uNaN on stack )
7 #n i' sumcount .b btst, 2 eq bra, ( called by <sum>, return 0. )
4 #n d3 subq, i' mover d3 cmp, ne ( field null? )
if, begin, 5 bsr, ne while, 3 bsr, ( no, while # precedes a brk )
2 eq bra, tc' ^nextchar jsr, again,
else, 2 :l t' 0. #n sp ) move,
then, tc' execute jmp, ( place number on astack )
3 :l t' #table +ttable a2 move, 2 #n a2 addq,
i' #chars d2 move, 1 #n d2 subq, ( char is digit? )
4 :l begin, a2 )+ d0 .b cmp, d2 eq -until, rts,
5 :l t' sepchars +ttable a2 move, 2 #n a2 addq,
3 #n d2 moveq, 4 bra, ( char is tab or brk? )
then, 1 #n i' sumcount addq, a1 sp -) move, ( count )
d1 tst, pl if, d3 d1 sub, then, d1 sp -) move, ( len of integer part )
rp )+ sp -) move, ;c ( addr -- addr length integerlength sign )
code pack ( addr length integerlen sign -- flag )
awide #n i' asp add, i' asp a1 move, ( alast )
0 #n a1 )+ move, 0 #n a1 )+ move, 0 #n a1 ) move, ( 0. )
i' asp a1 move, sp )+ d1 move, ne ( place sign )
if, 1 #n a1 ) .b move, then,
sp )+ d3 move, sp )+ d0 move, sp ) a0 move, ( parameters )
0 #n sp ) move, ( d3 = integer, d0 = len, a0 = string addr )
1 #n d0 subq, pl ( decrement len )
lif, -1 #n d3 cmp, eq ( no decimal point? )
if, d0 d3 move, 1 #n d3 addq, then,
awhole 1+ #n d3 cmp, pl ( too many integers? )
if, -1 #n sp ) move, 0c #n a1 ) .b or, next, ( make uNaN, exit )
then, d0 d2 move, d3 d2 sub,
awide 2* awhole - 2- #n d2 cmp, pl
if, -1 #n sp ) move, awide 2* awhole - 2- #n d2 moveq, then,
awhole 1+ #n d1 moveq, d3 d1 sub,
1 #n d1 addq, d1 d2 move, ( d1 = nybble parity )
1 #n d2 lsr, d2 a1 add, ( a1 = dest byte )
begin, begin, begin, begin,
a0 )+ d2 .b move, i' dpoint 3 + d2 .b cmp, ne until,
i' commapun 3 + d2 .b cmp, ne until,
080 #n d2 .b cmp, mi until,
0f #n d2 .b and, a1 ) d3 .b move, ( d2 char, d3 partner )
1 #n d1 and, eq
if, 0f #n d3 .b and, 4 #n d2 .b lsl, ( > high nybble )
d3 d2 .b or, d2 a1 ) .b move,
else, 0f0 #n d3 .b and, d3 d2 .b or, ( > low nybble )
d2 a1 ) .b move, 1 #n a1 addq,
then, 1 #n d1 addq,
d0 nt -until,
then, i' asp #n a0 move, a0 ) a1 move, ( not create "-0" )
a1 )+ d0 move, feffffff #n d0 and, ( mask off sign )
a1 )+ d0 or, a1 ) d0 or, 0 #n d0 cmp, ( all zero? )
eq if, a0 ) a1 move, 0 #n a1 ) .b move, ( yes, clear sign )
then, next;
: +ref ( token -- )
?arithmetic not
if dup c@ ['] forwarderror -
if drop exit
then then 1+ dup w@ 07ff 2dup and =
if toomanyrefs error 56 createrror
then 1+ swap w! ;
: allot# ( sign -- )
>r astring alen aintlen r> pack
if extradigits error 34 compilerror then compile alit a, ;
: toggle ( integer -- )
dup if off else on then ;
code 3dup ( a b c -- a b c a b c )
sp 8 )d sp -) move, sp 8 )d sp -) move, sp 8 )d sp -) move, next;
: name|function ( -- )
['] arithmetic vopen astring alen <find>
if dup compile, +ref drop
else drop ['] function vopen astring alen <find>
if nip execute ( execute function )
else ( couldn't find name, store string addr )
drop magic#2
begin >r magic#1 over = until >r astring alen rot 1+
begin r> magic#2 over = until drop
then then ;
code $char? ( char addr len -- char flag )
sp )+ d0 move, sp )+ a0 move, sp ) d1 move,
0 #n sp -) move, 1 #n d0 subq,
begin, a0 )+ d1 .b cmp, d0 eq -until, eq
if, -1 #n sp ) move, then, next;
: clausep? ( char -- flag \ true if char is a sepchar, excluding 0 and paren )
sepchars #sepchars 2- $char? nip ;
: moreclause? ( char -- char flag \ true if char isn't a sepchar )
sepchars #sepchars $char? 0= ;
code findtoken ( char -- token )
sp ) d0 move, i' #op+tokens d1 move, 1 #n d1 subq, 0 #n d2 moveq,
t' op+tokens +ttable a0 move,
begin, 2 #n a0 addq, a0 )+ d0 .b cmp, d1 eq -until, pl
if, a0 )+ d2 .b move, 8 #n d2 lsl, a0 )+ d2 .b move,
then, d2 sp ) move, next;
: numerical ( sign -- | translate a numerical atom *** )
asp awide 2* + rp@ 1- >
if recursing error 35 compilerror then ( too much recursion )
awide 2* needforth 0=
if noroom error 36 compilerror then ( out of dictionary )
parsenext
dup -1 = if drop allot# exit else
dup -2 = if drop name|function else
dup ascii ( = if drop clause drop else
dup ascii - = if drop 0= numerical exit else
dup ascii + = if drop numerical exit else
dup ascii ~ = if drop 0 numerical compile a~ else
dup ascii [ = if drop ascii ] getphrase interpretphrase else
37 syntaxerror ( number syntax error )
then then then then then then then
if compile aneg then ;
: compileop ( char -- )
dup findtoken ?dup ( an operator and # )
if 8 needforth
if compile, drop ( compile it )
else noroom error 36 compilerror then
else popsep = if 52 else 33 then ( 52 = attempt to push result )
syntaxerror then ; ( 33 = programmer: add op char to op+tokens )
: value ( -- char )
0 numerical
begin parsenext moreclause? while " %" $char?
while compileop again ;
: exponential ( -- char )
value
begin moreclause? while " ^" $char?
while >r value r> compileop again ;
: product ( -- char )
exponential
begin moreclause? while " */\" $char?
while >r exponential r> compileop again ;
: factor ( -- char )
product
begin moreclause? while " +-" $char?
while >r product r> compileop again ;
: clause ( -- char | heirarchical recursive descent compiler )
factor
begin moreclause? while " <>=&|" $char?
while >r factor r> compileop
again moreclause? if 51 syntaxerror then ;
: begincompile ( -- )
20 needforth 0= if noroom error 36 createrror then
4ed3 w, compile checkanswer ( start definition )
references w, ( comma, reference )
scanner , 0. a, ; ( pointer and answer fields )
code badname? ( str len -- 0 | -- addr | of illegal char )
sp )+ d1 move, 1 #n d1 subq,
sp ) a0 move, 0 #n sp ) move,
7e #n d2 moveq,
begin, a0 )+ d2 .b cmp, d1 mi -until,
mi if, 1 #n a0 subq, a0 sp ) move, then, next;
: badnamerror? ( addr len -- addr len | place cursor on bad character )
2dup badname? ?dup
if parsed - dup parsed +to negate selen +to
badname error 44 createrror then ;
: ucreate ( addr len -- | make header for forward reference )
dup 01f > if longname error 47 createrror then ( name is too long )
badnamerror? ( illegal char? )
2dup applic rot rot <find> ( does name exist? )
if 2drop 2drop ( yes, do nothing )
else drop recycledtoken -1 = ( no, drop found addr )
if drop notokens error 46 createrror then ( out of tokens, abort )
dup 10 + needforth 0=
if noroom error 36 createrror then
applic addr rot rot assign ( create new header )
align here lasttok +table ! ( update token )
4ed3 w, compile forwarderror ( point to error handler )
0 w, then ; ( 0 ref count )
: acreate ( str len -- | create header for normal calctoken )
dup 01f > if longname error 47 createrror then ( name is too long )
badnamerror? ( illegal char? )
local str local len len to str to
applic str len <find> ( name already exists? )
if lasttok to lasttok ?arithmetic ( yes, as expression? )
if usedname error 48 createrror then ( yes, error message )
dup c@ ['] forwarderror <> ( as forward reference? )
if usedname error 49 createrror then ( no, error message )
1+ w@ 17ff and 1+ references to ( yes, transfer ref count )
lasttok <becode> ( and discard old def )
else ['] function vopen str len <find> ( collision with function name )
if 2drop reservedname error 50 createrror
then drop recycledtoken -1 =
if notokens error 46 createrror then ( out of tokens, abort )
len 8 + needforth 0=
if noroom error 36 createrror then
applic addr str len assign ( create new header )
then drop align here lasttok +table ! ; ( resolve token )
: forwardrefs? ( [str len]*n n magic#1 tok -- flag | make fwd refs )
local tok tok to ( save token )
begin magic#1 = until dup ( dig for forward refs )
if tok exa 3 + dup w@ dup references to ( propagate ref count )
1+ swap w! tok <-refs> ( trick: so won't behead )
0 do ucreate loop ( create undefined name )
tok <becode> tok usetoken begincompile ( start def here )
1 ( flag: 1 forward ref minimum )
then tok lasttok to ; ( restore token )
: usetoken ( token -- )
dup -1 = if notokens error 46 createrror then ( out of tokens, abort )
dup lasttok to align here swap +table ! ;
: acompile ( flag -- | true = named, string of length selen at parsed )
aerror# off current oldvoc to ( save current vocabulary )
['] arithmetic <addto> ( add to arithmetic vocab )
precision precis to ( default precision )
1 references to ( self reference, no commas )
if newname ( named )
else recycledtoken usetoken ( unnamed expression )
then begincompile buildbody ( build definition )
oldvoc <addto> ; ( reopen old vocab )
: buildbody ( -- | translate expression to forth code )
parsed savebos to selen ( allows forward references )
0 magic#1
clause dup ascii ) = ( compile definition )
if 55 syntaxerror ( closing w/o opening parens )
else clausep? ( clause sep char? )
if beot parsed prevchar eos to ( yes, move remaining clauses )
movegap bos gap killivls ( update ivl table )
dup prevchar pop to ( prepare for reselection )
beot c@ popsep =
if beot nextchar beot to then ( discard sep or trailing underscore )
beot - selen to ( so cursor will move beyond exp )
then then compile placeanswer ( finish definition )
here lasttok exa - 7fff > ( *** )
if recursing error 35 compilerror then ( *** )
lasttok forwardrefs? ( forward references )
if selen to savebos parsed to ( prepare to recompile expression )
0 magic#1 ( magic # to resolve forward references )
clause 2drop ( recompile definition again )
compile placeanswer then drop ; ( finish definition )
: pocket? ( -- flag | set precis, lasttok, and oldpocket )
local count count off precision precis to ( init precis )
bos prevchar inresult? dup ( last char in result? )
if drop precis off bos
begin dup c@ popsep <>
while nextchar gap over < dotted 0= and ( dotted set by stripattr )
if drop beot bos eos to movegap tb gap c! ( insert a tab char )
beot knownplace 1 gap +to gap 1- gap killivls
gap swap eos to movegap bos to
0 exit then ( no popsep, assume no pocket )
again drop bos 0
begin drop prevchar dup inresult? dup
while drop dup c@ dpoint = ( char = decimal pt? )
if count precis to ( yes, set the precision )
else dup c@ commapun <> ( no, not a comma? )
if dup c@ popsep <> ( yes, not an popsep? )
if 1 count +to then ( yes, incr precision count )
then then dup 2+ c@ &calc = dup
until swap over ( hit calctoken or nonresult )
if dup 7 + oldpocket to ( start of pocket )
3 + @ adecode lasttok to ( for redefine )
lasttok eta dup if nip then pocketname to ( "" )
else drop precision precis to then then ; ( no calctoken )
: =name? ( -- flag \ false = no compiled name or names aren't identical )
local nstr local nlen
lasttok eta dup
if drop 2+ dup c@ 1f and nlen to 1+ nstr to
alen nlen = dup
if drop astring nstr alen same?
then then ;
: =clause? ( -- flag | true means clauses match )
selen selen 0
do parsed i + c@ dup ( grab next expression char )
oldpocket i 2* + w@ dup 4 shr and 0ff and <> ( no, match pocket? )
if 2drop 0 exit then ( no, return false )
clausep? if drop i leave then ( clause ends? )
loop 2* oldpocket + c@ 80 and 0= ; ( match, but short pocket? )
: -pocket ( -- | remove result, update gap and bos )
oldpocket prevchar oldpocket to ( including first result char )
bos gap over - oldpocket swap 2dup + gap to move ( move selection )
oldpocket bos to ( bos parsed to selsize selen to ) ; ( adjust pointers )
: redefinerror? ( -- flag | true means calctoken points to redefinerror )
oldpocket 4 - @ adecode lasttok to ( for redefine )
lasttok ['] redefinerror = ;
code hidebyte ( # -- hidden# | convert to 2byte hidden format )
sp ) d0 move, &firsthid #n sp 3 )d .b or, 4 #n d0 .b lsr,
&firsthid #n d0 .b or, d0 sp 2 )d .b move, next;
: namedclause? ( -- flag true if expression is named )
parsed selen preparse -3 = ;
: patchforward ( -- | so existing references to this word display uNaN )
references 07ff and 2 <
if lasttok eta if <behead> then ( no refs, remove both name )
lasttok recycle ( and token )
else lasttok usetoken
10 needforth 0= if noroom error 36 createrror then
4ed3 w, ( point token to dummy )
compile forwarderror references 07ff and 1- w, ( w/ 1 less reference )
then references f800 and 1 or references to ; ( so new def start fresh )
: newname ( -- | create a name from expression )
parsenext drop astring alen acreate ;
: -oldef ( -- | extract info from old definition, then discard )
lasttok exa 3 + w@ 5800 and references to ( get commaflag )
lasttok <<-refs>> ( decrement refs )
lasttok exa dup ['] freetoken exa <>
if 3 + w@ 7ff and references or references to ( get new refs cnt )
else drop references f800 and 1 or references to
then lasttok <becode> ; ( remove codespace )
: redefine ( -- | string of length selen at parsed )
current oldvoc to ['] arithmetic <addto> ( addto arithmetic vocab )
lasttok ['] redefinerror =
if references f800 and 1 or references to namedclause?
if newname
else recycledtoken usetoken then ( unnamed expression )
else -oldef namedclause?
if pocketname
if =name?
if parsenext drop lasttok usetoken ( same name )
else patchforward newname then ( different name )
else lasttok recycle newname then
else pocketname
if patchforward recycledtoken lasttok to then
lasttok usetoken ( change token table entry )
then then begincompile buildbody ( build definition )
oldvoc <addto> ; ( restore vocab )
code !pocket ( source dest count -- )
sp )+ d0 move, ( d0 = count )
sp )+ a1 move, sp )+ a0 move, ( a0 = source, a1 = dest )
d0 a0 add, d0 a1 add, d0 a1 add, 1 #n d0 subq,
begin, a0 -) d1 .b move, ( grab byte )
i' commapun 3 + d1 .b cmp, eq ( convert punctuation )
if, ascii , #n d1 .b moveq, ( from native language )
else, i' dpoint 3 + d1 .b cmp, eq ( into universal -- American )
if, ascii . #n d1 .b moveq, then, then,
d1 d2 move, &firsthid #n d2 .b or, d2 a1 -) .b move,
4 #n d1 lsr, &firsthid #n d1 .b or, d1 a1 -) .b move,
d0 nt -until, next;
code @pocket ( from to -- to' | copy pocket, removing high nybbles )
sp )+ a0 move, sp ) a1 move,
begin, a1 )+ d0 .b move, ( grab byte )
d0 d1 move, &firsthid #n d1 .b and,
&firsthid #n d1 .b cmp, eq ( in pocket? )
while, 4 #n d0 .b lsl, 0f #n d0 .b or, ( 1st nybble )
a1 )+ d0 .b and, ( 2nd nybble )
d0 d1 move, &firsthid #n d1 .b and,
&firstacc #n d1 .b cmp, ne ( if not accent byte )
if, i' popsep 3 + d0 .b cmp, ne
if, ascii , #n d0 .b cmp, eq ( reveal punctuation )
if, i' commapun 3 + d0 .b move, ( in the context )
else, ascii . #n d0 .b cmp, eq ( of the native language )
if, i' dpoint 3 + d0 .b move, then, then,
d0 a0 )+ .b move, ( copy byte )
&dln #n a0 )+ .b move, then, then, ( add dotted underline attrib )
again, a0 sp ) move, next;
: pushpocket ( -- | pushpocket -- discards selection )
local reslen ( total result length )
selected bos gap killivls ( selection will disappear )
beot partknown ( rest of text will change )
precis 0a min precis to ( truncate precision )
precis dup 0 <> - 1+ 2* ( digit + attribute chars + )
5 + selsize + reslen to ( token + hidden chars = result len )
reslen 11 + needtext 0= ( need 11, = 9 placemarker + 8 skip )
if lasttok <-refs> noroomcalc abort then
bos dup 7 + selsize !pocket ( copy selection into pocket )
ascii 0 encalc bos ! ( put 1st digit of result )
lasttok aencode bos 3 + ! ( place calctoken )
reslen gap +to gap 2- bos to ( update bos and gap )
precis 1+ 2* reslen to
precis 1- 0< 0= ( digits after decimal point? )
if oldpuns 0ff and 8 shl &dln + gap reslen - w! ( place dpoint )
3000 &dln + gap reslen 2
do 2dup i - w! 2 +loop 2drop ( place fraction digits )
then 9f lasttok exa 3 + and! ; ( clear poppedflag & autohide bits )
: -expression ( -- | discard expression, place remainder at beot )
parsed dup gap to prevchar bos to ( put cursor on last result char )
parsed selen over + dup rot ( s+p s+p p )
do i c@ clausep? ( clause separator char? )
if drop ( i=addr of char after expression )
parsed selen + i - selen to ( length of remaining expression )
bos beot i movetext ( move remainder to beot )
prevchar pop to ( prepare for getremains )
bos to exit then ( all done )
loop drop selen off ( no more selection to compile )
oldpocket prevchar 3 + @ ( pocket? sets oldpocket )
adecode lasttok to ( token of pocket )
9f lasttok exa 4 + and! ; ( clear poppedflag )
: preimmediate ( -- | setup for executing expression just pushed )
aerror# off marker off textify? on ( mimic precalc )
anew commas off lasttok lastcalc to ( mimic aexec )
-9 beot +to markerchar encalc beot ! ( put calctoken )
markerchar hidebyte beot 7 + w! ( push a markerchar )
['] placemarker aencode beot 3 + ! ( textify will execute this )
gap prevcalc? drop
mover prevchar lasttok exa 5 + ! ( store pointer field )
beot scanbot to ( for noroomcalc )
preset gap 4 + mover to ( for relative refs & sums )
2 pass to ;
code pretextify ( -- commapun dpoint | prepare for texitfy )
i' commapun sp -) move, i' dpoint sp -) move,
i' oldpuns 2+ i' commapun 3 + .b move, ( trick textify )
i' oldpuns 3 + i' dpoint 3 + .b move,
3 #n i' pass move, i' beot a0 move, i' gap a1 move,
begin, a1 -) d0 .b move, &calc #n d0 .b cmp, ne
while, d0 a0 -) .b move, ( move pocket above gap )
again, 1 #n a1 addq, a1 i' mover move, a0 i' scanner move, next;
: immediacy ( -- | calculate this result and display it )
pushpocket ( hide the surface expression )
preimmediate lasttok execute
pretextify >r >r textify drop ( the HEART of this routine )
r> commapun to r> dpoint to ( restore values for recalc)
mover gap to gap prevchar bos to ( readjust pointers )
scanner beot to beot eos to preset
eos 400 + eot min wrapthru rewindow ( Terry's magic incantation )
selected redisplay pass off ;
: initpocket ( -- )
['] redefinerror aencode oldpocket 4 - ! ; ( -- in case of compile error )
: pushclause ( -- | change expression into result, etc )
namedclause? ( named expression? )
if pocket? ( yes, follows an old result? )
if =clause? ( yes, expressions match? )
if redefinerror? 0= ( yes, pocket = redefinerr? )
if =name? ( no, exprn's = compiled name? )
if -expression exit then then ( yes, discard clause )
then initpocket redefine -pocket ( replace )
else 1 acompile then ( compile new definition )
else pocket?
if =clause? ( does its clause match? )
if redefinerror? 0= ( yes, pocket = redefinerr? )
if =name? ( no, exprn's = compiled name? )
if -expression exit then then ( yes, discard clause )
then initpocket redefine -pocket ( recompile )
else 0 acompile ( no poc, compile w/o name )
then then immediacy ;
code prepush ( -- addr/flag | set up for autopush only )
i' bou a0 move, 0 #n sp -) move, i' popsep 2+ d1 .w move,
i' parsed a1 move, a0 i' parsed move, ( set parsed )
begin, a1 )+ a0 )+ .b move, ( copy expression )
a1 )+ d0 .b move, &firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq
while, a0 -1 )d d1 .b cmp, ne ( ignore trailing popsep )
while, &calc #n a1 ) .b cmp, ne ( and calc )
while, &calc #n a1 1 )d .b cmp, ne ( or accented calc )
while, a1 ) d0 .b move, &firsthid #n d0 .b and,
&firstacc #n d0 .b cmp, eq
if, 1 #n a1 addq, a1 sp ) move, leave, then, ( accent: done )
again, spc #n a0 -) .b move, ( add trailing space )
i' parsed a0 sub, a0 i' selen move, next; ( set selen )
: accenterror ( addr -- )
justmovetext 44 aerror# to ( put cursor on accented char )
badname error showcalc abort ;
: autopushedaccent ( addr -- )
preset scanbot findmarker justmovetext 9 beot +to ( remove markrchar )
dup beot < if beot - gap + 9 + then ( reopen below gap )
accenterror ;
: autopush ( -- | called by checkanswer or redefinerror )
r> drop ( abandon word whose token = lastcalc )
lastcalc lasttok to ( lastcalc is word being recompiled )
parsed pastresult parsed - 2+ ( length of popped expression )
dup noroomcalc? ( make sure enough room )
eou swap - bou to
prepush ?dup ( copy > buffer, set parsed & selen )
if clearundo ( undo prepush )
autopushedaccent then ( stop, show 1st accented char )
redef ( called by redefinerror? )
if pocketname off ( for redefine )
else lasttok eta dup
if nip then pocketname to ( for redefine )
['] redefinerror aencode ( no, set calctoken to redefinerror, )
scanner ! ( -- in case of compile error )
redef on redefpopped on ( just like in redefinerror )
then redefine ( redefine token -- in lastcalc )
clearundo ( undo prepush )
28 lasttok exa 3 + or! ( set autohide=20 & discrepancy=8 bits )
lasttok aencode scanner ! ( reset calctoken )
preset ( so relative refs work )
lasttok execute ; ( execute new definition )
code stripattr ( addr -- addr'|0 | strip attributes, 0 = unaccented )
sp ) a0 move, 0 #n sp ) move, ( sp: clear accentflag )
1 #n a0 addq, a0 a1 move, ( a0: source, a1: destination )
begin, a0 )+ d0 .b move, d0 d1 .b move, ( byte = attribute? )
&firsthid &attr or #n d1 .b and, &attr #n d1 .b cmp, eq
if, -1 #n i' dotted move,
else, &skip #n d0 .b cmp, ne
if, d0 a1 )+ .b move, ( no, move byte/char; is accent? )
&firsthid #n d0 .b and, &firstacc #n d0 .b cmp, eq
if, sp ) tst, eq if, a1 sp ) move, ( yes, set accentflag addr )
then, then, then, then, i' gap a0 cmp, nc
until, a1 i' gap move, i' parsed a1 sub, a1 i' selen move, next;
code prevcalc? ( addr -- flag | true if result char has calctoken )
sp ) a0 move,
begin, tc' ^prevchar jsr, a0 1 )d d0 .b move,
&firsthid &dln or #n d0 .b and, &dln #n d0 .b cmp, eq
while, 3 #n d2 moveq, a0 2 )d d0 .b move, d0 d1 .b move,
&firsthid #n d1 .b and, &firstacc #n d1 .b cmp, eq ( accent? )
if, a0 3 )d d0 .b move, 4 #n d2 moveq, then, ( yes, bump offset )
&calc #n d0 .b cmp, eq ( calctoken? )
if, d2 a0 add, a0 i' mover move, ( yes, store in mover )
-1 #n sp ) move, next, then, ( return true )
again, 0 #n sp ) move, next;
: addpopsep ( -- \ add popsep char to gap )
popsep 8 shl &dln + gap w! 2 gap +to ; ( add popsep char )
: showpocket ( -- | copy hidden expression to surface text )
gap prevcalc? ( ** why test this? ** )
if mover nextchar gap min 8 + mover - noroomcalc?
gap bos to gap visible? 0= ( is char displayed? )
if display selected then ( easy way to do window table )
gap prevchar c@ popsep <> ( pocket, popsep there? )
if addpopsep then ( no, add popsep char )
40 mover @ adecode exa 3 + or! ( set poppedflag )
gap pop to gap bos to
mover 4 + bos @pocket gap to ( copy hidden expression )
beot partknown bos op to
gap prevchar bos to addpopsep redef
if showselen ( cursor on bac char )
else gap prevchar eos to movegap ( cursor on last popped char )
then redisplay beot wrapthru ( screen w/ new cursor )
selected widecursor
else mover prevchar parsed stripattr drop ( no pocket, strip underlnes )
parsed eot 1+ killivls rewindow refresh widecursor then ;
code ^nextcalc ( -- | uses register a0 )
begin, 1 :l a0 )+ d0 .b move, &calc #n d0 .b cmp, ne ( calctoken? )
while, &skip #n d0 .b cmp, 1 ne bra, tc' ^sk> jsr, ( skip char? )
again, rts, ;c
code nextcalc ( addr -- addr' | 1st byte after &calc )
sp ) a0 move, tc' ^nextcalc jsr, a0 sp ) move, next;
code nextcalc? ( end -- flag | true if &calc between mover and end )
i' mover a0 move, 1 #n a0 addq,
tc' ^nextcalc jsr, a0 a1 move, ( find calctoken )
sp ) a0 move, tc' ^nextchar jsr, a1 a0 cmp, nc
if, a1 i' mover move, -1 #n sp ) move, ( not past end )
else, 0 #n sp ) move, then, next;
: popped? ( -- flag | true = mover points to a def with poppedflag set )
mover @ adecode dup ['] redefinerror =
if drop popsep? ( so copied-up expressions copy ok )
else exa 3 + c@ 40 and 0 <> then ;
code pastresult ( addr -- addr' | ignores accents, even in next result )
sp ) a0 move,
begin, a0 1 )d d0 .b move, ( scan past result )
&firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq ( dotted underline attr? )
while, a0 2 )d d0 .b move, d0 d1 .b move,
&firsthid #n d1 .b and, &firstacc #n d1 .b cmp, eq ( accent? )
if, a0 3 )d d0 .b move, then, ( yes, grab next byte )
&firsthid &dln or d0 .b and, &calc #n d0 .b cmp, ne ( another result? )
while, tc' ^nextchar jsr,
again, a0 sp ) move, next;
: multipop ( -- )
local end local count
count off selected beot end to
parsed inresult?
if parsed prevcalc?
if mover prevchar parsed to ( incl all of leading result )
then then parsed eos to movegap ( move selection above gap )
beot mover to
begin end nextcalc? ?panic 0= and ( allow interruptions )
while popped? 0=
if count on
mover nextchar pastresult eos to movegap
showpocket beot mover to then ( pop pocket )
again end beot < not
if end pastresult eos to movegap then ( past end of everything )
?panic count or
if gap prevchar bos to gap visible?
if redisplay else display then
widecursor ?panic
if notcalculated error then
else recalc then ; ( none were popped, autopush )
code popsep? ( -- flag | true if popsep in result after mover )
i' mover a0 move, -1 #n sp -) move, ( a0: starting addr )
i' popsep 3 + d1 .b move, ( d1: popsep )
&firsthid &dln or #n d3 .b move, ( d3: calc mask )
a0 -1 )d d0 .b move, d3 d0 .b and, &calc #n d0 .b cmp, eq ( calctoken? )
if, tc' ^nextchar jsr, then, ( yes, skip pocket )
begin, a0 1 )d d2 .b move, d3 d2 .b and,
&dln #n d2 .b cmp, eq ( yes, dotted underlined? )
while, a0 ) d1 .b cmp, 1 eq bra, ( popsep? )
a0 2 )d d2 .b move, d3 d2 .b and, &calc #n d2 .b cmp, ne
while, a0 3 )d d2 .b move, d3 d2 .b and, &calc #n d2 .b cmp, ne
while, tc' ^nextchar jsr, ( stop on next calctoken )
again, 0 #n sp ) move, next, ( no popsep )
1 :l tc' ^nextchar jsr, a0 ) d1 .b cmp, eq ( skip popsep, two popseps? )
if, next, then, ( yes, leave selection alone )
a0 i' parsed move, a0 i' bos move, ( adjust parsed & bos )
begin, a0 ) d1 .b cmp, ne
while, a0 1 )d d0 .b move, ( scan past result )
&firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq ( dotted underline attribute? )
while, a0 2 )d d0 .b move, d0 d2 .b move,
&firsthid #n d2 .b and, &firstacc #n d2 .b cmp, eq ( accent? )
if, a0 3 )d d0 .b move, then, ( yes, grab next byte )
&firsthid &dln or d0 .b and, &calc #n d0 .b cmp, ne ( another result? )
while, tc' ^nextchar jsr,
again, i' parsed a0 sub, a0 i' selen move, next; ( adjust selen )
code resultchars? ( -- flag | true if attribute byte between mover & gap )
i' parsed a0 move, i' gap a1 move,
begin, a0 )+ d0 .b move,
&firsthid &dln or #n d0 .b and, &dln #n d0 .b cmp, eq ( attr byte? )
if, -1 #n sp -) move, next, ( yes, return -1 )
then, a0 a1 cmp, lt
until, 0 #n sp -) move, next;
: getremains ( -- flag )
gap bos to pop nextchar eos to movegap ( reselect )
preset getselect ;
: multipush ( -- )
needsglobal? parsed stripattr ?dup ( strip attributes )
if accenterror then ( trap accents )
begin pushclause selen ( compile, pocket, calc, & display expression )
while getremains 0= ?panic or ( prepare to push another exp )
until ?panic
if selected bos op to gap prevchar bos to
gap showaftercalc notcalculated error
else recalc then fixcursor ; ( calculate rest of text )
: push|pop ( -- )
selen 1 < if collapse showpocket else multipush then ;
: push|multipop ( -- | parsed and selen are already set )
lockedsel ( check if in a locked document )
gap nextcalc? ( is there a calctoken? )
if mover parsed dup nextchar inrange ( 1st char hiding calctoken? )
if gap nextcalc? 0= ( yes, and no other calctoken? )
if popped? ( yes, is it popped? )
if popsep? ( yes, sel contains popsep? )
if push|pop exit ( yes, push or recalc )
then then then then multipop ( multiple pop )
else resultchars? ( no, are there any result chars? )
if parsed prevcalc? ( yes, sel is part of a pocket? )
if popped? ( yes, is it popped? )
if popsep? ( yes, sel contains popsep? )
if push|pop ( push remaining or just recalc )
else multipush then ( assume ok to push )
else bos nextchar tapmove showpocket then ( no, pop )
else multipush then ( not part of result, push )
else multipush then then ; ( no, push for the first time )
: pop|recalc
bos inresult? ( cursor inside result? )
if gap nextcalc? bos prevcalc? or ( yes, includes active calctoken? )
if beot pastresult eos to movegap ( yes, move cursor )
gap prevchar bos to preset popsep? ( popped expression? )
if recalc ( yes, recalc )
else showpocket then ( no, show the expression )
else recalc then ( not active calc calctoken, recalc )
else recalc then ; ( no, recalculate entire text )
: fcalc ( -- | pass selection to forth interpretter )
2 newlex to bos gap over - interpret
bot eot 1+ hideivls rewindow
?extended if collapse else display then widecursor ;
: getselect ( -- flag | if there is a selection: parameters )
local flag flag on selected
local end gap prevchar end to bos end = ( nothing selected? )
if flag off selen off ( yes, return false )
else bos
begin dup c@ dup clausep? swap spc = or ( leading clausep or space )
while nextchar dup beot 1- >
if drop gap prevchar flag off leave then ( no expression )
again bos to selsize selen to
then bos dup parsed to dup mover to scanner to ( for scanning later )
dotted off flag ;
: <resetcalc> ( -- )
rtn encalc endtext 3 - ! ( for Boyer-Moore ascan )
0 hidebyte dup dup 10 shl or endtext ! endtext 4 + w!
oldbos off oldeos off ( recover from pass 3 more quickly )
redef off -userounded aerror# off ( initialize flags, etc )
anew pass off ; ( clear arithmetic stack )
: resetcalc ( -- )
indcalc rule ( indicate that calc is in progress )
clearundo removecalcs ( clean up erased stuff )
dirtytext? on ( mark text dirty )
undop off ( can't undo calculations )
<resetcalc> ;
: Calc ( -- | the Calculate command )
resetcalc getselect ( reset, get selection parameters )
if push|multipop ( selection: lots of decisions )
else pop|recalc ( no selection: either pop or recalc )
then 0 0 3 indicate rule ; ( clear "calc" in ruler )
: initcalc ( -- )
rtn encalc endtext 3 - ! ( so recalc will work )
0 hidebyte dup dup 10 shl or endtext ! endtext 4 + w!
['] arithmetic <empty> ; ( no naming collisions )
code totab ( n addr -- n addr addr' -1 | n addr 0 \ 0= not enough tabs )
sp ) a0 move, sp 4 )d d1 move, ne
if, 1 #n d1 subq,
begin,
begin, tc' ^nextchar jsr, tb #n a0 ) .b cmp, ne
while, rtn #n a0 ) .b cmp, ls ( any kind of break? )
if, 1 :l 0 #n sp -) move, next, then,
again,
d1 nt -until,
then, 0 #n d2 moveq,
begin, begin, begin, tc' ^nextchar jsr,
markerchar #n a0 ) .b cmp, eq
if, &calc #n a0 2 )d .b cmp, eq ( skip placemarker )
if, 9 #n a0 addq,
then, then, a0 ) .b d2 move, ascii $ #n d2 .b cmp, ne
until, spc #n d2 .b cmp, ne
until, ascii + #n d2 .b cmp, ne
until, a0 sp -) move, -1 #n sp -) move, next; ( return addr', -1 )
code endsum? ( addr -- addr flag \ -1 means done )
i' asp a0 move, 03 #n a0 ) .b btst, 3 ne bra, ( NaN means done )
sp ) a0 move, rtn #n a0 ) .b cmp, eq ( points to cr? )
if, tc' ^prevchar jsr, rtn #n a0 ) .b cmp, ls
if, ds #n a0 ) .b cmp, 3 ge bra, ( ds, pb, or rtn? )
then, markerchar #n a0 ) .b cmp, eq ( placemarker? )
if, a0 1 )d d0 .b move, &firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq ( dotted underline attribute? )
if, &calc #n a0 2 )d .b cmp, eq ( cr placemark )
if, tc' ^prevchar jsr, rtn #n a0 ) .b cmp, ls
if, ds #n a0 ) .b cmp, 3 ge bra, ( ds, pb, or rtn? )
then, then, then, then,
2 :l 0 #n sp -) move, next,
then, ds #n a0 ) .b cmp, ne ( to doc break? )
if, pb #n a0 ) .b cmp, 2 ne bra, then, ( to pagebreak? )
3 :l -1 #n sp -) move, next;
: ?tab ( addr -- n addr' )
0 swap
begin prevchar dup c@ dup break? 0=
while tb = if swap 1+ swap then
again drop ;
code scan ( addr n char -- n' | of scanned chars )
sp )+ d0 move, sp )+ d1 move, d1 d2 move, pl
if, sp ) a0 move,
begin, a0 )+ d0 .b cmp, eq
if, d2 d1 sub, d1 sp ) move, next, ( found char )
then, d2 nt -until,
then, -1 #n d1 moveq, d1 sp ) move, next;
: >pack ( addr count -- string len integer sign )
alen to pad 20 + alen move pad 20 + alen
over c@ ascii - = if 1- swap 1+ swap 1 else 0 then >r ( sign )
2dup dpoint scan dup >r 0< 0= if 1- then r> r> ;
: aconvert ( n -- flag | == a )
base >r decimal
dup abs <# #s swap sign #> >pack pack r> base to ;
code @calctoken? ( addr -- sign false, == a | addr -- addr true )
i' userounded? tst, 1 ne bra, ( userounded, not extract )
sp ) a0 move, 0 #n d3 moveq, ( d3= sign, 0=positive )
begin,
begin, &calc #n a0 2 )d .b cmp, 2 eq bra, ( this char in a calctoken? )
a0 ) d2 .b move, ( no, grab a leading char )
t' ignoretable +ttable a1 move, 2 #n a1 addq,
i' #ignorable d0 move, 1 #n d0 subq,
begin, a1 )+ d2 .b cmp, d0 eq -until, eq ( ignorable char? )
while, 3 #n d0 .w cmp, mi ( yes, minus sign or paren? )
if, d3 tst, eq ( yes, change sign )
if, -1 #n d3 moveq, else, 0 #n d3 moveq, then, then,
tc' ^nextchar jsr, ( skip ignorable char )
again, &calc #n a0 2 )d .b cmp, ne
if, 1 :l -1 #n sp -) move, next, then, ( true=use surface text )
2 :l markerchar #n a0 ) .b cmp, eq ( placemarker? )
while, tc' ^nextchar jsr, ( yes, skip placemarker )
again, d3 sp ) move, ( d3= sign change )
0 #n sp -) move, ( false=executed calctoken )
1 #n i' sumcount addq, ( increment sumcount )
3 #n a0 add, ( end of encoded token )
3 #n d1 moveq, 4 #n sp subq, ( encoded token = 4 bytes )
a0 )+ sp ) .b move, a0 )+ sp 1 )d .b move, ( sp = encoded token )
a0 )+ sp 2 )d .b move, a0 )+ sp 3 )d .b move,
0f0f0f0f #n sp ) and, sp 2 )d d0 .b move, 4 #n d0 .b lsl,
d0 sp 3 )d .b or, sp 1 )d sp 2 )d .b move, sp ) d0 .b move,
4 #n d0 .b lsl, d0 sp 2 )d .b or, ( sp = decoded token )
0 #n sp ) .w move, tc' execute jmp, ;c ( execute token )
: @element ( addr -- )
@calctoken? ( execute calctoken? )
if packstring ( no, extract number )
if 30 digitserror then ( extraction failed )
else if aneg then then ; ( apply sign to extracted # )
: <sum> ( pointerfield -- \ == sum )
sumcount off 2+ @ ?tab ( get the column )
prevbrk totab ( prev column )
if @element ( last row is special )
else 0. ( skip empty last row )
then endsum? 0= ( must test for end of sum in all cases ** )
if begin prevbrk totab ( prev column )
if @element a+ ( add element to stack )
then endsum? until ( done? )
then 2drop ;
: +userounded ( -- | force calculation to grab values from surface text )
userounded? on ;
: -userounded ( -- | force calculation to grab values from surface text )
userounded? off ;
: <sumrounded> ( pointerfield -- )
+userounded <sum> -userounded ;
: <avg> ( pointerfield -- | == a )
<sum> sumcount aconvert if 31 digitserror then a/ ;
code endrel? ( n addr -- <exit> | n addr | exit when boundary hit )
sp ) a0 move, ds #n a0 ) .b cmp, ne
if, pb #n a0 ) .b cmp, ne
if, i' eot a1 move, 1 #n a1 sub, a0 a1 cmp, ge
if, next, then, ( not a boundary, continue )
then, then, awide #n i' asp add, ( hit boundary )
i' asp a1 move, 0c #n a1 ) .b move, ( return uNaN )
08 #n sp add, ( 2drop )
0c #n rp add, tc' <exit> jmp, ;c ( exit from do loop in <rel> )
: get( ( -- | check for opening paren )
parsenext ascii ( <> if 54 syntaxerror then ; ( no opening paren )
: <rel> ( y x flagsfield -- | == a )
magic#1 sumcount to ( flag for packstring )
2+ @ ?tab swap rot + dup 0< ( -- y addr x' flag )
if 2drop drop uNaN ( too few tabs )
else swap rot ?dup ( starting at a return )
if dup 0< ( find requested return )
if abs 0 do endrel? prevbrk loop
else 0 do nextbrk endrel? loop
then then swap ?dup ( find requested tab )
if swap totab
if nip nip else 2drop uNaN exit then ( not enough tabs )
else nextchar ( after the return )
then @element then ; ( grab the element )
: <relrounded> ( y x flagsfield -- | == a )
+userounded <rel> -userounded ;
: relative ( [??] n -- )
dup 1 2 inrange 0=
if 38 syntaxerror then ( more than 2 or less than 0 coordinates )
dup 1 = if 0 swap then drop ( only one, vert = 0 )
[compile] literal [compile] literal ( coordinates )
compile r@ ( the rest of relative addr )
userounded? if compile <relrounded> else compile <rel> then ;
: get#error ( error# -- )
in 1+ len - parsed over - selen +to parsed to ( so showselen works )
syntaxerror ;
: get#s ( addr len -- )
over + limit to in to base >r decimal
3 0 do word len
while str len base number
while ?stack
if r> base to 44 get#error then ( stack underflow or overflow )
loop r> base to len
if 45 get#error then ; ( can't find )
: getphrase ( delimiter -- )
local delimiter delimiter to
parsed dup astring to in to alen off
in selen + limit to delimiter scanfor ( scan for delimiter )
in 1- c@ delimiter <> if 39 syntaxerror then ( no delimiter )
in parsed to in 1- astring - alen to ( adjust variables )
alen 1+ negate selen +to ;
: interpretphrase ( -- ) sp@ savesp to
astring alen get#s
savesp sp@ - 2 shr 1-
relative ;
code redefpopsep? ( -- flag | true = popsep within result )
i' scanner a0 move, i' popsep 3 + d2 .b move,
begin, tc' ^nextchar jsr, ( first time: skip pocket )
a0 ) d2 .b cmp, eq
if, tc' ^nextchar jsr, a0 i' parsed move, ( found popsep )
-1 #n sp -) move, next, ( true flag )
then, a0 1 )d d1 .b move, ( d1 = potential underline attribute )
&firsthid &attr or #n d1 .b and, &attr #n d1 .b cmp, ne
until, 0 #n sp -) move, next; ( false flag )
: atranscribe ( -- | copy to pocket to bot )
local savegap gap savegap to
scanner 4 + nextchar scanner - ( length of pocketed text )
dup noroomcalc? ( make sure enough room )
eou swap - bou to
bou parsed to ( set parsed )
scanner 4 + parsed @pocket gap to ( copy pocket to bot )
parsed stripattr drop ( strip all underlines )
spc gap c! savegap gap to preset ; ( terminate copy w/ space & skipmarker )
: forwarderror ( -- )
uNaN r> drop ;
: redefinerror ( == a | redefine executing calctoken )
pass 1 <> if uNaN exit then ( so immediacy not crash )
redef on ( createrror calls showredef )
redefpopsep? dup redefpopped to ( popsep char follows result? )
if autopush then ( yes, autopush doesn't return )
atranscribe ( pop pocket into undo buffer )
namedclause?
if ['] arithmetic vopen astring alen <find> ( named, in arithmetic vocab? )
if exa 2+ c@ ['] forwarderror <> ( yes, forward reference? )
if drop usedname error 40 createrror ( no, pop it )
then then drop
then namedclause? acompile ( compile with or w/o name )
clearundo ( destroy atranscribe buffer )
lasttok aencode scanner ! ( place calc token in text )
preset ( so relative refs work )
lasttok execute ; ( execute new definition )
: receivetoken ( addr -- | process a received calctoken )
['] redefinerror aencode swap ! ;
code nextcalcorlockedcalc ( addr -- addr' | 1st byte after &calc *** )
sp ) a0 move,
begin, 1 :l a0 )+ d0 .b move,
0fe #n d0 .b and, &calc #n d0 .b cmp, ne ( calctoken? )
while, &skip #n d0 .b cmp, 1 ne bra, tc' ^sk> jsr, ( skip char? )
again, a0 sp ) move, next;
: fixcalcs ( --- | fix up calc pockets in getforward text )
bot
begin nextcalcorlockedcalc dup eot < ( *** )
while dup receivetoken 1+
again drop ;
: linkcalc ( addr -- | link calculation token into eraselist )
1+ @ adecode dup ?arithmetic
if eraselist swap 3 + ! eraselist to else 2drop then ;
: unlinkcalc ( addr -- flag | unlink calc token from eraselist )
1+ @ adecode dup ?arithmetic 0=
if 2drop -1 exit then drop ( don't remove what isn't linked )
local tok local field
eraselist tok to field off
begin dup tok <>
while tok 0= if drop 0 exit then ( failure )
tok exa 5 + field to field @ tok to
again exa 5 + @ field
if field ! else eraselist to then -1 ; ( success )
: removecalcs ( -- )
begin eraselist ?dup ( chain exists? )
while dup exa dup [ tc' freetoken ] literal = ( yes, chain broken? )
if 2drop eraselist off exit then ( yes, assume finished)
5 + @ eraselist to -refs again ; ( no, remove calc def )
code copypopped ( from to -- from' to' )
sp )+ a1 move, sp ) a0 move, ( a0: from, a1: to )
i' popsep 3 + d1 .b move, ( d1: popsep char )
begin, 2 bsr, eq
while, a0 ) d0 .b move, ascii : #n d0 .b cmp, eq ( copy result/surface )
if, ( named: discard )
begin, 2 #n a0 addq, 1 bsr, 2 bsr, ne until, ( remaining expression )
a1 -2 )d d1 .b cmp, ne
if, d1 a1 )+ .b move, a1 -2 )d a1 )+ .b move, ( no popsep, add one )
then, &calc #n a0 ) .b cmp, eq ( calctoken? )
if, tc' ^prevchar jsr, then, leave, ( yes, back up )
then, &calc #n a0 2 )d .b cmp, ne ( calctoken? )
while, &calc #n a0 3 )d .b cmp, ne ( no, are you sure? )
while, a0 )+ a1 )+ .b move, a0 )+ a1 )+ .b move, 1 bsr, ( yes, copy chr)
again, a0 sp ) move, a1 sp -) move, next, ( a0: from, a1: to )
1 :l a0 ) d0 .b move, &firsthid #n d0 .b and, ( skip accent )
&firstacc #n d0 cmp, eq if, 1 #n a0 addq, then, rts,
2 :l a0 1 )d d0 .b move, &firsthid &dln or #n d0 .b and, ( dotted undl? )
&dln #n d0 .b cmp, rts, ;c
code copypushed ( from to -- from' to' )
sp )+ a1 move, sp ) a0 move,
a1 -1 )d d0 .b move, &firsthid #n d0 .b and,
&firstacc #n d0 cmp, eq if, 1 #n a1 subq, then, ( discard accent )
a1 -1 )d d0 .b move, d0 d1 .b move, &firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, eq
if, 0b #n d1 .b and, eq ( other attributes, too? )
if, 1 #n a1 subq, ( no, dscard dot'd undrln byte )
else, 0ff 04 xor #n a1 -1 )d .b and, ( yes, strip dot'd undrlin bit )
then, then,
begin, 2 bsr, eq ( copy result w/o underlines or accents )
while, a0 )+ a1 )+ .b move, ( copy result char )
a0 ) d0 .b move, 0b #n d0 .b and, ne ( examine attribute byte )
if, a0 ) d0 .b move, ( other attributes, too )
&firsthid 0b + #n d0 .b and, d0 a1 )+ .b move, ( strip dotd underline )
then, 1 #n a0 addq, 1 bsr,
again, a0 sp ) move, a1 sp -) move, next,
1 :l a0 ) d0 .b move, &firsthid #n d0 .b and, ( skip accent )
&firstacc #n d0 cmp, eq if, 1 #n a0 addq, then, rts,
2 :l a0 1 )d d0 .b move, &firsthid &dln or #n d0 .b and,
&dln #n d0 .b cmp, rts, ;c ( dotted underline attr? )
: copypocket ( from to -- from' to' | copy calc pocket )
>r dup 1+ mover to nextchar
popped? popsep? and
if ( popped, replace token with redefinerror, remove exp if named )
&calc r@ c!
['] redefinerror aencode r@ 1+ ! ( will be redefined, on next recalc )
ascii ? hidebyte r@ 5 + w!
r> 7 + copypopped
else ( not popped, remove pocket and dotted underlines )
r> copypushed then ; ( remove dotted underline first )
code <line> ( x1 y1 x2 y2 flag -- )
(regs d4 d5 d6 d7 a3 to) rp -) movem, sp )+ a3 move,
sp )+ d7 move, sp )+ d6 move, sp )+ d5 move, sp )+ d4 move,
d4 tst, nt ( the 4th stack item )
if, 1 :l ramstart #n a1 move,
/scan #n d6 .w move, d5 d6 .w mulu, d6 a1 add,
d4 d6 .w move, 3 #n d6 .w asr, 7f #n d6 .w andi,
d6 a1 .w add, d4 d6 .w move, d6 .w not, 7 #n d6 .w andi, d7 tst, eq
if, d6 a1 ) .b bclr,
else, pl
if, d6 a1 ) .b bchg,
else, d6 a1 ) .b bset,
then, then, rts,
then, d6 d2 .w move, d4 d2 .w sub, d2 d0 .w move, mi
if, d0 .w neg, then,
d7 d3 .w move, d5 d3 .w sub, d3 d1 .w move, mi
if, d1 .w neg, then,
d2 .w tst, mi
if, d7 d5 exg, d6 d4 exg, d3 .w neg, d2 .w neg, then,
/scan #n d6 .w move, d3 .w tst, mi
if, d6 .w neg, then,
a3 d7 move, d6 a0 .w move, d1 d0 .w cmp, pl
if, d2 d3 .w move, d3 .w neg, d1 d1 .w add, d0 d0 .w add,
1 .w bsr, 1 #n d2 .w subq, pl
if,
begin, d1 d3 .w add, pl
if, a0 a1 add, d0 d3 .w sub, then,
1 #n d6 .b subq, cs
if, 7 #n d6 .b andi, 1 #n a1 addq, then,
d7 tst, eq
if, d6 a1 ) .b bclr,
else, pl
if, d6 a1 ) .b bchg,
else, d6 a1 ) .b bset,
then, then,
d2 nt -until,
then,
else, d1 d3 move, d1 d2 .w move, d3 .w neg, d1 d1 .w add,
d0 d0 .w add, 1 .w bsr, 1 #n d2 .w subq, pl
if,
begin, d0 d3 .w add, pl
if, 1 #n d6 .b subq, cs
if, 7 #n d6 .b andi, 1 #n a1 addq, then,
d1 d3 .w sub, then, a0 a1 add,
d7 tst, eq
if, d6 a1 ) .b bclr,
else, pl
if, d6 a1 ) .b bchg,
else, d6 a1 ) .b bset,
then, then,
d2 nt -until,
then, then, (regs d4 d5 d6 d7 a3 from) rp )+ movem, next;
code <point> ( x y flag -- )
sp )+ d3 move, sp )+ d2 move, sp )+ d1 move,
ramstart #n a0 move,
/scan #n d0 .w move, d2 d0 .w mulu, d0 a0 add,
d1 d0 .w move, 3 #n d0 .w asr, 7f #n d0 .w andi,
d0 a0 .w add, d1 d0 .w move, d0 .w not, 7 #n d0 .w andi, d3 tst, eq
if, d0 a0 ) .b bclr,
else, pl
if, d0 a0 ) .b bchg,
else, d0 a0 ) .b bset,
then, then, next;
code <box> ( x1 y1 x2 y2 flag -- )
(regs d4 d5 d6 d7 to) rp -) movem,
sp )+ a1 move, ( get arguments )
sp )+ d7 move, sp )+ d6 move, sp )+ d5 move, sp )+ d4 move,
d5 d7 cmp, lt
if, d5 d7 exg, then, ( test order)
d4 d6 cmp, lt
if, d4 d6 exg, then,
ramstart #n a0 move, /scan #n d0 .w move, ( screen constants )
d5 d0 .w mulu, d0 a0 add, ( first row affected )
d4 d0 .w move, 3 #n d0 .w asr, 7f #n d0 andi, d0 a0 add,
( calculate the masks for the first and last byte of a row )
d4 d0 .b move, 7 #n d0 .b and, -1 #n d1 .b moveq, d0 d1 .b lsr,
d6 d0 .b move, d0 .b not, 7 #n d0 .b and, -1 #n d3 .b moveq,
d0 d3 .b lsl,
d4 d2 .w move, 3 #n d2 .w asr, 7f #n d2 .w and, ( left addr )
d6 d0 .w move, 3 #n d0 .w asr, 7f #n d0 .w and, ( right addr )
d2 d0 .w sub, eq ( difference between left & right addrs )
if, d3 d1 .b and, 0 #n d3 .w moveq, then, ( same, merge masks )
-1 #n d2 .b moveq, ( middle mask )
d0 d6 .w move, 2 #n d6 .w subq, ( diff-2=len-2ends-1until )
d5 d7 .w sub, ( calculate # of lines-1 until )
/scan 1- #n d5 moveq, d0 d5 .w sub, ( width-[len-2] = width-1-diff )
d0 .w tst, eq ( if only a single byte )
if, 1 #n d5 .w subq, then, ( there is still two affected )
a1 d0 move, eq ( test type flag )
if, d1 .b not, d2 .b not, d3 .b not, ( clear needs negated )
begin, d1 a0 )+ .b and, d6 d4 .w move, pl
if,
begin, d2 a0 )+ .b move,
d4 nt -until,
then, d3 a0 )+ .b and, d5 a0 add,
d7 nt -until,
else, pl
if,
begin, d1 a0 )+ .b eor, d6 d4 .w move, pl
if,
begin, d2 a0 )+ .b eor,
d4 nt -until,
then, d3 a0 )+ .b eor, d5 a0 add,
d7 nt -until,
else,
begin, d1 a0 )+ .b or, d6 d4 .w move, pl
if,
begin, d2 a0 )+ .b move,
d4 nt -until,
then, d3 a0 )+ .b or, d5 a0 add,
d7 nt -until,
then, then, (regs d4 d5 d6 d7 from) rp )+ movem, next;
( Simulate target compilation environment jrs 18 April 1988 )
: intvaddr execute addr ;
: i' word str len find
if intvaddr else ." can't find " str len type abort then ;
: tromaddr' i' ;
: tc' c' ;
: t' ' ;
: +ttable +table ;
: inword ( addr -- token *** \ find nearest token below addr )
local address address to
local tok tok off
local tokexa tokexa off
tokens 0 do i exa tokexa address inrange
if i tok to i exa tokexa to then
loop tok ;
: ,s ( ** -- \ compiles numbers until encounter pb or ds -- vaguely like ;s )
begin in word
edde if
begin dup limit < 0= if drop exit then
dup str < while
dup c@ dup pb = swap ds = or
if in to exit then
nextchar
again drop -1
else drop str limit < then
while str len base number if , then
again ;
: { ( msgaddr -- | Compile message ending w/ }, each line ends w/ rtn ** )
local msgaddr msgaddr to
local linelen linelen off ( length of line, clear it )
local more more on ( more: -1 means not done )
1 in +to ( skip leading space )
begin in 1- nextchar c@ rtn =
if rtn c, 1 linelen +to then ( put an extra rtn in )
rtn scanfor ( grab up to but not incl rtn )
str len dup
if -trailing then dup
if 2dup over + swap
do i c@ dup ascii } =
if more off ( end of message )
else dup [ &firsthid &attr or ] literal and
&attr = ( allow normal )
over &lastacc 1+ < or ( bold, underlined or accentd chrs )
if dup c, 1 linelen +to
then then drop
loop
then 2drop more
while rtn c, 1 linelen +to ( put rtn in )
again linelen msgaddr w! ; ( store length )
( vl ) tactivate asmb68
: mkmsg ( "name" | -- msgaddr ** )
code ( read "name" :: source code/input stream )
( relocatable inline code for message )
0c pc)d a0 lea, ( inline code skips over itself )
0 #n d0 moveq, a0 )+ d0 .w move, ( a0 points at length field )
a0 sp -) move, d0 sp -) move, next; ( runtime: -- addr len )
here 0 w, ; ( msgaddr )
( vl ) tdeactivate asmb68
: patchrom ( -- \ uses str and len )
['] user current = ( Are we adding words to user)
if extant dup [ #vocs 4 * ] literal + swap
do i w@ 7fff <
while i w@ vopen 40000 < ( voc in address space of rom? )
if i w@ vopen str len <find> ( yes, found word in voc? )
if nip dup ['] here < ( yes, and not a rom integer? )
if ." redefining ROM " ( yes, issue warning )
here swap +table ! ( point ROM to user definition )
lasttok eta if <behead> then ( so trace is less frustrating )
lasttok recycle ( what do we need it for anyway? )
else drop ." Warning: a ROM integer already has the name "
then str len type space exit
then drop then
4 +loop then ;
( DEBUG VOCABULARY -- 68000 dissassembler/decompiler jrs&job84aug23)
tactivate debug
code opcode-map nx ) jsr, ;c ( 16 opcode group tokens )
16 2 * allot
: w. ( # -- | print signed 16 bit number )
dup 8000 and if ffff0000 or then . ;
( m p -> | mask the opcode word and check for = pattern bits)
: &ocw= swap opcode-word and = ;
( m s -> | s & m shift and mask opcode-word's bit field)
: subf opcode-word swap / and ;
( -> | Extract the named subfield from the opcode word)
: eareg 7 1 subf ; : sourcereg eareg ;
: eamode 7 8 subf ; : sourcemode eamode ;
: destreg 7 200 subf ; : datareg destreg ;
: opmode 7 40 subf ; : destmode opmode ;
: data ff 1 subf ; : 8-bit-dispf data ;
: sizef 3 40 subf ; : qdata destreg ;
: ir 1 20 subf ; : >d-regf eareg ;
: sz 1 40 subf ;
: rm 1 8 subf ;
: dr 1 100 subf ;
: ccf f 100 subf ;
: ex-type 3f 80 subf ;
: ms-type 3 200 subf ;
: rs-type 3 8 subf ;
: vector f 1 subf ;
( job84oct01)
code cc-names nx ) jsr, ;c
" trnthilsnccsneeqnvvsplmigeltgtle"
here over allot swap move ( move string from input to array )
( -> | decode the 16 condition codes )
: condition cc-names ccf 2 * + 2 space type ;
( -> | compute and print the target address )
: displacement 8-bit-dispf 0=
if ( 16 bit ) 2 disaddr +to disaddr w@ dup 8000 and
if ( negative ) ffff0000 or then ( 32 bits now ) 0 ( del )
else 8-bit-dispf dup 80 and if ffffff00 or then 2 ( delta )
then disaddr + ( add delta ) + ( add displacement ) . ;
( job&jrs85Apr22)
( -> | print the size of the operation)
: size sizef 2 <
if sizef if ." .w" else ." .b" then then ;
( ew -> f | decode index extension word, output xsize flag)
: dindex dup 8000 and if ." a" else ." d" then
dup 1000 / 7 and 1 .r dup ff and . 800 and ( flag ) ;
( f -> | Print the size of the index register data used)
: xsize if ." xl)d" else ." xw)d" then ;
: <ea>> reg 0= if 2 disaddr 2+ w@ w. else
reg 1 = if 4 disaddr 2+ @ . else
reg 2 = if 2 disaddr 2+ w@ w. ." pc)d" else
reg 3 = if 2 disaddr 2+ w@ dindex ." pc" xsize else
reg 4 = if disaddr 2+ osize 3 = dr and osize 2 = or
if @ . 4 else w@ w. 2 then ." #n"
then then then then then ;
( -> | compute approximate effective address, update disaddr)
: <ea> mode 0= if 0 ." d" reg 1 .r else
mode 7 = if <ea>> else ." a" reg 1 .r
mode 1 = if 0 else
mode 2 = if 0 ." )" else
mode 3 = if 0 ." )+" else
mode 4 = if 0 ." -)" else
mode 5 = if 2 disaddr 2+ w@ w. ." )d" else
mode 6 = if 2 disaddr 2+ w@ dindex xsize
then then then then then then then then disaddr +to ;
( -> | compute the approximate effective address)
: ea eamode mode to eareg reg to sizef osize to <ea> ;
( -> | compute the approximate source effective address)
: easource sourcemode mode to sourcereg reg to <ea> ;
( -> | compute the approximate destination effective address)
: eadest destmode mode to destreg reg to <ea> ;
( -> | Decode bit instruction type)
: bitype sizef
if sizef 1 =
if ." togl"
else sizef 2 = if ." clear" else ." set" then
then
else ." test" then ;
: <ocm-imm> ( -- | decode immediate opcodes )
disaddr 2+ sizef 2 =
if @ . 4 else w@ w. 2 then
." #n" disaddr +to ( adjust for argument )
ea f00 0 &ocw= if ." or"
else f00 200 &ocw= if ." and"
else f00 400 &ocw= if ." sub"
else f00 600 &ocw= if ." add"
else f00 a00 &ocw= if ." eor"
else ." cmp"
then then then then then ." i" ;
( -> | decode map 0 opcodes and print fields )
: ocm0 dr ( bit 8 seperates these two )
if datareg . 38 8 &ocw=
if opmode . eareg . ." movep"
else ." d" datareg 1 .r bitype easource ." dyna bit" then
else f00 800 &ocw=
if bitype 2 disaddr +to disaddr w@ w.
easource ." stat bit" ( special )
else <ocm-imm> ( static bit one )
then then ;
( job84sep19)
( -> | print the fields of opcode map 1, byte move)
: ocm1 0 osize to easource eadest ." .b move" ;
( -> | print the fields of opcode map 2, long move)
: ocm2 2 osize to easource eadest ." move" ;
( -> | print the fields of opcode map 3, word move)
: ocm3 1 osize to easource eadest ." .w move" ;
( -> | unassigned opcode maps)
: ocma ." unassigned " ;
: ocmf ocma ;
( job84aug23)
: ocm5 sizef 3 <
if qdata 0= if 8 else qdata then . ." #n"
ea size dr if ." subq" else ." addq" then
else 38 8 &ocw=
if 2 disaddr +to disaddr w@ dup 8000 and
if ffff0000 or then disaddr + . ( branch addr )
." d" eareg 1 .r condition ( decode cc) ." dbcc"
else ea ." scc"
then then ;
: ocm6 displacement f00 0 &ocw= f00 100 &ocw= or ( cc 0, 1)
if dr if ." bsr" else ." bra" then
else condition ." bcc" then ;
: ocm7 100 0 &ocw=
if data . ." #n d" datareg 1 .r ." moveq" else ocma then ;
( each of 36 misc. opcodes is 6 bytes: mask, id and token)
code miscellany nx ) jsr, ;c
f000000 , 0 w, fc000c0 , 0 w, 1c00180 , 0 w, 1c001c0 , 0 w, f000200 , 0 w,
fc002c0 , 0 w, f000400 , 0 w, fc004c0 , 0 w, f000600 , 0 w, fc006c0 , 0 w,
fc00800 , 0 w, ff80840 , 0 w, fc00840 , 0 w, ff80880 , 0 w, f800880 , 0 w,
ff808c0 , 0 w, f000a00 , 0 w, fc00ac0 , 0 w, fff0afc , 0 w, f800c80 , 0 w,
ff00e40 , 0 w, ff80e50 , 0 w, ff80e58 , 0 w, ff80e60 , 0 w, ff80e68 , 0 w,
fff0e70 , 0 w, fff0e71 , 0 w, fff0e72 , 0 w, fff0e73 , 0 w, fff0e74 , 0 w,
fff0e75 , 0 w, fff0e76 , 0 w, fff0e77 , 0 w, ffe0e7a , 0 w, fc00e80 , 0 w,
fc00ec0 , 0 w,
( -> | decode the miscellaneous opcodes, print fields)
: ocm4 24 0 do i 6 * miscellany + ( base address) dup
w@ ( mask) over 2+ w@ &ocw=
if 4 + w@ dup execute name leave
else drop i 23 = if ." ???" then then loop ;
( name fields name fields name fields )
: negx ea size ; : sr>move ea ; : chk ea datareg . ;
: lea chk ; : clr negx ; : ccr>move ea ;
: neg negx ; : >ccrmove ea ; : not, negx ;
: >srmove ea ; : nbcd ea ; : link eareg . ;
: pea ea ; : tst negx ; : tas ea ;
: sickbird ; : trap vector . ; : movec 1 and . ;
: reset ; : nop ; : unlk ." a" eareg . ;
: stop ; : rte ; : rtd ;
: rts ; : trapv ; : rtr ;
: swap, link ; : jsr ea ; : jmp ea ;
: ext.word link ; : ext.long link ; : >uspmove unlk ;
: usp>move unlk ;
: reg-list 2 disaddr +to disaddr w@ ;
: to]-movem base 2 base to reg-list w. base to ea sz 0= if ." .w" then ;
: from]-movem to]-movem ;
24 6 4 fillarray miscellany
negx sr>move chk lea clr ccr>move neg >ccrmove not, >srmove
nbcd swap, pea ext.word to]-movem ext.long tst tas sickbird
from]-movem trap link unlk >uspmove usp>move reset nop stop rte
rtd rts trapv rtr movec jsr jmp
: ocm8 1f0 100 &ocw=
if destreg . rm . sourcereg . ." sbcd"
else 1c0 c0 &ocw=
if ea ." d" datareg 1 .r ." divu"
else 1c0 1c0 &ocw=
if ea ." d" datareg 1 .r ." divs"
else dr
if ." d" datareg 1 .r ea
else ea ." d" datareg 1 .r
then size ." or"
then then then ;
: ocm9 sizef 3 =
if ea ." a" destreg 1 .r
dr 0= if ." .w" then ." suba"
else dr eamode 2 < and
if sourcereg . destreg . rm . size ." subx"
else dr
if ." d" datareg 1 .r ea
else ea ." d" datareg 1 .r
then size ." sub"
then then ;
: ocmb sizef 3 =
if dr 2* osize to easource ." a" destreg 1 .r
dr 0= if ." .w" then ." cmpa"
else 138 108 &ocw=
if ." a" sourcereg 1 .r ." )+ a" destreg 1 .r ." )+ " size ." cmpm"
else dr
if ." d" datareg 1 .r ea size ." eor"
else ea ." d" datareg 1 .r size ." cmp"
then then then ;
: <ocmc> 1f8 140 &ocw= 1f8 148 &ocw= or 1f8 188 &ocw= or
if sourcereg . destreg . ." exg regs"
else 1f8 100 &ocw= 1f8 108 &ocw= or
if sourcereg . destreg . rm ." abcd"
else dr
if ." d" datareg 1 .r ea
else ea ." d" datareg 1 .r
then size ." and"
then then ;
: ocmc sizef 3 =
if ea ." d" destreg 1 .r ." mul"
dr if ascii s else ascii u then emit
else <ocmc> then ;
: ocmd sizef 3 =
if dr 2* osize to easource ." a" destreg 1 .r
dr 0= if ." .w" then ." adda"
else 138 100 &ocw= 138 108 &ocw= or
if sourcereg . destreg . rm . size ." addx"
else dr
if ." d" datareg 1 .r ea
else ea ." d" datareg 1 .r
then size ." add"
then then ;
: ocme sizef 3 =
if ms-type . dr . ea ." shf/rot mem"
else datareg . dr . sizef . ir . rs-type . sourcereg .
." shf/rot reg"
then ;
10 2 0 fillarray opcode-map
ocm0 ocm1 ocm2 ocm3 ocm4 ocm5 ocm6 ocm7 ocm8 ocm9 ocma ocmb ocmc ocmd ocme ocmf
( ocw -> token | Compute the token to execute for the 16 ocm's)
: ocm-token 800 / 1e and opcode-map + w@ ;
( a n -> a' | disassemble from address a for n bytes)
: <uncode> over 2 mod abort" address must be even!"
over + dislim to disaddr to
begin disaddr dislim <
while ?keystep 0=
while disaddr w@ opcode-word to
cr disaddr 7 .r opcode-word 5 .r space ( addr & opcode)
opcode-word ocm-token execute ." ," 2 disaddr +to
again disaddr ;
: uncode ( a n -- ) <uncode> drop ;
;s
behead <ea>> behead &ocw= behead >d-regf behead 8-bit-dispf
behead ccf behead bitype behead ex-type behead condition
behead data behead destreg behead datareg behead destmode
behead rm behead dislim behead disaddr behead displacement
behead <ea> behead eareg behead eamode behead miscellany
behead ir behead reg behead eadest behead opcode-map
behead osize behead dindex behead ms-type behead cc-names
behead ocm0 behead ocm1 behead ocm2 behead ocm3
behead ocm4 behead ocm5 behead ocm6 behead ocm7
behead ocm8 behead ocm9 behead ocma behead ocmb
behead ocmc behead ocmd behead ocme behead ocmf
behead ea behead xsize behead vector behead ocm-token
behead dr behead mode behead opmode behead opcode-word
behead size behead reg-list behead rs-type behead sourcereg
behead sz behead sizef behead subf behead sourcemode
behead qdata behead <ocmc> behead <ocm-imm> behead easource
Hereinafter are some notes regarding the disassembler:
word action or purpose
op-map table, with 16 elements, indexed by opcode-word
opcode-word copy of first 32 bits of opcode
("800 / 1e and" converts it to an offset in op-map)
disaddr address of opcode currently being disassembled
dislim address just after last opcode
( decompiler -- see jrs85-86)
( these all have the stack diagram: token -- flag )
: ?int ['] int0 ['] intf inrange ;
: ?brans dup ['] <0bran> = over ['] <bran> = or
over ['] <leave> = or swap ['] <0leave> = or ;
: ?branls dup ['] <0branl> = over ['] <branl> = or
over ['] <leavel> = or swap ['] <0leavel> = or ;
: ?loops dup ['] <loop> = swap ['] <+loop> = or ;
: ?locs dup ['] <locals> = swap ['] <;lp> = or ;
: ?; dup ['] <;> = swap ['] <;lp> = or ;
: ?btoken ['] tierf over u< over 0= or swap ?int 0= and ;
( printing names and numbers )
: .name ( naddr -- ) space dup 1+ swap c@ 1f and type ;
: @token ( addr -- addr' token ) dup dup c@ ?btoken
if 1+ swap c@ else 2+ swap w@ then ;
: .<#> ( n -- ) ." <" 7f over u< over 100 u< and
if ascii - emit 100 - negate then <# #s #> type ." >" ;
( these all have the stack diagram: addr naddr -- addr' )
: .lit drop dup @ . 4 + ;
: .wlit drop dup w@ . 2+ ;
: .blit drop dup c@ dup 7f > if 100 - then . 1+ ;
: .loc dup 1+ swap c@ 3f and space type dup 1+ swap c@ ." +" 1 .r ;
: .<"> .name dup 1+ swap c@ 2dup space type + ascii " emit ;
: .loops decoding if cr 3 spaces then .name ;
: .ctrl .loops dup c@ .<#> 1+ ;
: .ctrll .loops dup w@ .<#> 2+ ;
: .; ." ;" nip -1 swap ;
: .voc .name 1+ @token name dup @ ." (" . ." bytes of code ) " .; ;
: .ints drop dup 1- w@ name 1+ ;
: .compile .name @token name ;
code unpack ( == | -- len integer sign )
0 #n d1 moveq, i' asp #n a0 move, a0 ) a0 move, aacum #n a1 move,
d1 d3 move, a0 )+ d3 .b move, awide 1- #n d0 moveq,
begin, a0 )+ d1 .b move, d1 d2 move,
4 #n d2 lsr, 30 #n d2 ori, d2 a1 )+ .b move,
0f #n d1 andi, 30 #n d1 ori, d1 a1 )+ .b move,
awhole 2/ #n d0 cmpi, eq if, dpoint #n a1 )+ .b move, then,
d0 nt -until, aacum #n a1 move, awhole #n d0 moveq,
begin, 30 #n a1 )+ .b cmpi, d0 ne -until,
aacum awide 2* + #n a1 move, awide 2* awhole - #n d1 moveq,
begin, 30 #n a1 -) .b cmpi, d1 ne -until, 1 #n d1 cmpi, eq
if, 0 #n d1 moveq, then, d0 d1 add,
d1 sp -) move, d0 sp -) move, d3 sp -) move, next;
: a. ( a == | print the top element of the arithmetic stack )
unpack adrop dup 08 and
if 04 and if ascii ? else ascii > then emit ." ????.??" 2drop
else 1 and if ascii - emit then over
if aacum awhole + swap - swap type
else drop .
then then ;
: getn ( "arithmetic number format" | -- )
[compile] " >pack pack abort" can't convert this string" ;
: .alit ( addr -- addr' ) dup a@ space a. awide + ;
: .refs ( addr naddr -- addr | display reference count )
.name dup w@ ." <refs:" . dup c@ >r
r@ 40 and if ." poppedflag " then ( poppedflag )
r@ 20 and if ." autohidebit " then ( autohide bit )
r@ 8 and if ." discrepancybit " then ( discrepancy bit )
r> 10 and if ." commabit" then ; ( commabit )
: .checkanswer ( addr naddr -- addr' )
.refs ( display ref count, bitflags )
2+ dup @ ." pointer:" . ( pointer field, )
space dup c@ 80 and if " new" else " old" then type ( answerbit, )
." answer:" 4 + .alit ; ( and answer )
: .extender drop .name ;
here
code toklentable nx ) jsr, ;c
t' <exitlp> w, 2 w,
t' <;lp> w, 2 w,
t' <locals> w, 2 w,
t' <local> w, 2 w,
t' <0bran> w, 2 w,
t' <bran> w, 2 w,
t' <leave> w, 2 w,
t' <0leave> w, 2 w,
t' blit w, 2 w,
t' <branl> w, 3 w,
t' <0branl> w, 3 w,
t' <leavel> w, 3 w,
t' <0leavel> w, 3 w,
t' wlit w, 3 w,
t' lit w, 5 w,
t' vocab w, 8 w,
t' alit w, 0e w,
t' checkanswer w, 12 w,
t' <"> w, -1 w,
t' compile w, -2 w,
here swap - tromaddr' toklens !
: tokenlen ( addr -- length \ length of entire token at addr )
local adr local tok
adr to adr @token tok to drop
toklentable toklens over + swap
do i w@ tok =
if i 2+ w@ fffd over u<
if ffff = ( muy especial token )
if adr 1+ c@ 2+ ( <"> )
else adr 1+ c@ ?btoken 3 + ( compile )
then then exit then ( "normal" control element )
4 +loop adr c@ ?btoken 2+ ; ( tres ordinaire token )
: .calcstuff ( flag addr naddr token -- flag addr' ) local token token to
token ['] checkanswer = if .checkanswer else
token ['] placeanswer = if drop .; else
token ['] alit = if .name .alit else
token ['] redefinerror =
token ['] forwarderror = or if .refs .; else
token .extender then then then then ;
: .next2 ( flag addr naddr token -- flag addr' )
local token token to
token ?; if drop .; else
token ['] <exit> = if drop ." exit" else
token ['] <exitlp> = if drop ." exit" 1+ else
token ?loops if .loops -1 do# +to else
token ?locs if .name dup c@ .<#> 1+ else
token ?brans if .ctrl else
token ?branls if .ctrll else
token .calcstuff then then then then then then then ;
: .next ( a -> a f | Step through a word by addresses, true if at end )
local token
0 swap @token dup token to eta if 2+
token ['] blit = if .blit else
token ['] wlit = if .wlit else
token ['] lit = if .lit else
token ['] <"> = if .<"> else
token ['] <local> = if .loc else
token ['] compile = if .compile else
token ['] <do> = if .loops 1 do# +to else
token ['] vocab = if .voc else
token .next2 then then then then then then then then then
token drop swap ;
: .romint ( token inttoken -- )
cr exa 2+ @ over 0ff and + @ . ." rom integer" name ;
: .ramint ( token -- ) cr dup exa 2+ @ . ." ram integer" name ;
: .code ( token -- ) cr ." code " dup name
exa dup <csize> uncode ;
: .body ( addr -- addr' ) decoding on begin .next ?keystep or until ;
: .see ( token -- ) dup cr ." :" name 2 spaces exa 2+ do# off .body drop ;
: see ( "name | -- )
' dup swab 0ff and dup ?int if .romint else drop
dup exa w@ 4ed3 = if .see else
dup exa w@ 4ed2 = if .ramint else
.code then then then ;
: swapbytes ( addr1 addr2 -- \ swap values stored at addr1 and addr2 )
2dup @ swap @ rot ! swap ! ;
: newbug ( -- )
initedde getforward save re ;
( Trace function )
code @regs ( -- registers )
(regs d0 d1 d2 d3 d4 d5 d6 d7 a0 a1 a2 a3 a4 a5 a6 a7 to) sp -) movem, next;
: <.regs> ( regaddr -- )
cr 2 spaces 8 0 do i 9 .r loop
61 64 do cr space i emit 8 0 do dup i 2 shl + @ 9 .r loop 20 +
-3 +loop drop ;
: .saveregs
saveregs <.regs> cr ;
: .regs @regs sp@ <.regs> 10 0 do drop loop ;
: ?tabcol ( col -- ) edde
if drop tb emit
else x - dup 1 < 0= if spaces else drop then then ;
code traceon ( -- | turn trace back on )
i' ctrace tst, eq ( 0: high level tracing )
if, tc' tracenext #n nx move,
tc' tracenest #n np move,
else, tc' triggernest #n np move, ( -1: low level tracing )
tc' triggernext #n nx move,
then, next;
code surrogatable nx ) jsr, ;c ( -- )
tc' tracetier1 , tc' tracetier2 , tc' tracetier3 ,
tc' tracetier4 , tc' tracetier5 , tc' tracetier6 , tc' tracetier7 ,
tc' tracetier8 , tc' tracetier9 , tc' tracetiera , tc' tracetierb ,
tc' tracetierc , tc' tracetierd , tc' tracetiere , tc' tracetierf ,
code oldtiertable nx ) jsr, ;c ( -- )
tc' tier1 , tc' tier2 , tc' tier3 ,
tc' tier4 , tc' tier5 , tc' tier6 , tc' tier7 ,
tc' tier8 , tc' tier9 , tc' tiera , tc' tierb ,
tc' tierc , tc' tierd , tc' tiere , tc' tierf ,
code returntrace ( -- | phase three. Restore old environment ** jrs 26jun )
(regs d0 d1 d2 d3 d4 d5 d6 d7 a0 a1 a2 a3 a4 a5 a6 a7 from) saveregs movem,
i' saveip sp -) move, i' savesr sp -) .w move, ( restore rte frame )
tc' triggernext #n nx move, ( install exit from tracing )
tc' triggernest #n np move, rte, ;c
code ascendtrace ( -- | phase three. Restore old environment ** jrs 26jun )
0 #n d0 moveq, i' codetoken 2+ d0 .b move, ne ( turn code level trace off )
if, d0 d1 .b move, d0 d0 add, 1 #n d0 subq, d0 d0 add,
d0 a0 move, t' oldtiertable 4 * .tb + a0 add,
bp d0 move, d1 d0 .b move, d0 d0 .w add, d0 d0 .w add, d0 a1 move,
a0 ) a1 ) move,
then, 0 #n i' codetoken move,
(regs d0 d1 d2 d3 d4 d5 d6 d7 a0 a1 a2 a3 a4 a5 a6 a7 from) saveregs movem,
i' saveip sp -) move, i' savesr sp -) .w move, ( restore rte frame )
7f #n sp ) .b and, ( clr "T" bit in sr copy )
tc' tracenext #n nx move, ( start high level tracing )
tc' tracenest #n np move,
-1 #n i' toggletrace move, ( display next word in calling word )
0 #n i' ctrace move, rte, ;c
code ctraceoff
0 #n d0 moveq, i' codetoken 2+ d0 .b move, ne
if, d0 d1 .b move, d0 d0 add, 1 #n d0 subq, d0 d0 add,
d0 a0 move, t' oldtiertable 4 * .tb + a0 add,
bp d0 move, d1 d0 .b move, d0 d0 .w add, d0 d0 .w add, d0 a1 move,
a0 ) a1 ) move,
then, tc' traceoff jmp, ;c ( do traceoff )
code saveUregs ( -- )
(regs d0 d1 d2 d3 d4 d5 d6 d7 a0 a1 a2 a3 a4 a5 to) uraniumregs movem, next;
: c-trace ( token -- )
traceoff saveUregs
dup codetoken to 0ff >
if codetoken 8 shr dup 1- 4 * surrogatable + @ ( exa of surrogate )
swap +table ! ( store surrogate )
then ctrace on traceon ;
: hl-trace ( token -- )
+table dup tracepointer to 0 +table - 4 / traceiling to
stepping on ctrace off traceon toggletrace on ;
: @rtnaddr ( rp -- token addr true \ false )
@ dup 10 shr 0 +table ffff and 2dup endtable ffff and inrange
if - 4 / ( token )
dup exa rot ffff and ( addr )
over <csize> over < 0= ( reasonable offset? )
if + -1 exit then ( yes )
then 2drop drop 0 ;
: swapenviron ( -- )
crt addr tracecrt addr swapbytes ( allow easy tracing of the editor )
edde addr tracedde addr swapbytes ;
: getchoice ( -- key )
ascii [ emit stepping ( wait for key choice )
if key else <?k> if stepping on key drop key else -1 then then
dup 20 > if dup emit else space then ." ]" ; ( show key choice )
: .statbit ( flag char -- )
swap 0= if drop ascii - then emit ;
: .statreg ( bitpattern -- )
local mask mask to
" T?S??421???XNZVC" 0
do 8000 i shr mask and over i + c@ .statbit
loop drop ;
: tracecodeline ( stackframe -- stackframe )
swapenviron
25 ?tabcol space savesr 11 shr .statreg saveip 1 uncode
21 ?tabcol getchoice swapenviron ;
: traceline ( rp delay -- key )
swapenviron ( go to trace environment )
swap >r >r 25 ?tabcol .s ( show stack prior to execution *** )
cr r> 2 .r ( elapsed time in "ticks" *** )
r> @rtnaddr
if swap name ( show name of traced word )
0d ?tabcol decoding off .next 2drop ( show name of word to be executed )
then 21 ?tabcol getchoice ( *** )
swapenviron ; ( go back to nontrace environment )
: <rdump> ( addr len -- \ display return stack )
over + swap
do cr i @rtnaddr
if swap name decoding off .next 2drop
else i @ . then
?keystep if leave then
4 +loop ;
: forthloop ( rp rp0 -- )
>r >r sp@ oldsp@ to sp@ stackcopy sp0 sp@ - move ( protect data and )
r@ oldrp@ to r@ rstackcopy r> r> swap - move ( return stacks )
toggletrace on 2 spaces quit ;
: dochoice ( rp key -- \ respond to key choice ) swapenviron dup if
dup ascii c = if stepping off else ( continuous )
dup ascii d = if toggletrace on over @rtnaddr ( descend )
if nip @token nip dup ['] execute =
if drop >r over r> swap then
dup swab 0ff and ?int
if drop ( integer, nop for now )
else dup exa w@ ['] dochoice exa w@ =
if +table tracepointer to ( high level )
else swapenviron toggletrace off c-trace
2drop exit ( code trace )
then then then
else dup ascii f =
if 2drop rp@ 4 - rp0 forthloop -1 -1 ( forth loop )
else
dup ascii i = if toggletrace on over ( ignore/don't execute this )
begin dup @ 10 shr tracepointer ffff and = ( word )
if dup @rtnaddr
if nip tokenlen swap 2+
dup w@ rot + swap w! leave
then then 4 + again else
dup ascii l = if toggletrace on font >r qfont font to ." stack" cr
." 's calling called key" r> font to else ( *** )
dup ascii n = if 2drop 2 spaces traceoff swapenviron ( end tracing )
exit else
dup ascii q = if 2drop traceoff swapenviron quit else ( quit )
dup ascii r = if toggletrace on rp@ 4 + rp0 over - ( show rtn stk )
<rdump> else
dup ascii s = if toggletrace on over 4 -
begin 4 + dup @rtnaddr until drop nip .see else
dup ascii u = if toggletrace on over ( ascend )
begin 4 + dup @rtnaddr until drop nip
dup traceiling to
+table tracepointer to else
dup spc <> if stepping if toggletrace on font >r qfont font to
." Continuous, Down, Forth, Ignore, Legend," cr
." No trace, Quit, Return stack, See, Up" r> font to then else
drop 0
then then then then then then then then then then then then 0=
if dup @rtnaddr ( automatic )
if @token nip dup ?; over ['] <exit> = or swap ['] <exitlp> = or
if traceiling <>
if begin 4 + dup @rtnaddr ( end of def )
until drop +table tracepointer to toggletrace on ( ascend )
then
else drop then
then then drop swapenviron traceon ;
: docodechoice ( rteframe key -- | doesn't return )
swapenviron r> drop ( this word doesn't return via return stack )
rp@ @rtnaddr if drop ['] docodechoice = if r> drop then then
dup ascii b = if saveip 10 uncode drop 0 else
dup ascii c = if stepping off else ( continuous )
dup ascii f = if drop rp@ 4 - rp0 forthloop 0 else
dup ascii l = if font >r qfont font to ." status register" cr
." pc op instruction key" r> font to drop 0 else ( *** )
dup ascii m = if .saveregs drop 0 else
dup ascii n = if 7f savesr addr and! 2 spaces else ( end tracing )
dup ascii p = if .s cr else
dup ascii q = if drop 2 spaces swapenviron quit else ( quit )
dup ascii r = if saveregs 10 + @ 0 +table - 4 / cr name ( show )
saveregs 34 + @ .next 2drop ( return )
rp@ 4 + rp0 over - <rdump> drop 0 else ( stack )
dup ascii s = if codetoken .code drop 0 else
dup ascii u = if swapenviron ( ascend to high level )
saveregs 10 + @ tracepointer to ascendtrace else
dup spc <> if stepping
if drop 0 font >r qfont font to
." Brief disassembly, Continuous trace," cr
." Forth, Legend, Machine State, No trace, Print Stack, Quit," cr
." Return stack, See, Up" r> font to
then then then then then then then then then then then then then swapenviron
if returntrace else displaycodetrace then ;
: tracetest ( -- flag ) -1 ;
: displaycodetrace ( stackframe -- | doesn't return )
ctraceoff tracecodeline docodechoice ;
: displaytrace ( -- show stack and other info )
vdelay vticks@ - ( duration count )
toggletrace off tracetest
if rp@ swap traceline rp@ swap dochoice
else drop traceon then vdelay vticks! ;
: tracetotext tracecrt off tracedde on ;
: tracetoscr tracecrt on tracedde off ;
: resume ( -- \ resume tracing - with changes to data stack )
oldrp@ rp0 = abort" Resume what? You weren't tracing!"
ctrace abort" Can't resume, use 'continue'"
rp0 rp! rstackcopy dup rp0 oldrp@ - 4 - + ( restore return stack )
do i @ r> r> rot r> swap >r >r >r >r -4 +loop
rp0 oldrp@ to traceon ;
code newsp ( addr -- \ store addr in stack pointer register )
sp )+ sp move, next;
: continue ( -- \ continue exactly from where forth was invoked )
oldrp@ rp0 = abort" Continue what? You weren't tracing!"
sp! sp0 oldsp@ -
if oldsp@ newsp ( restore data stack )
stackcopy oldsp@ sp0 over - move sp0 oldsp@ to
then rp0 rp! rstackcopy dup rp0 oldrp@ - 4 - + ( restore return stack )
do i @ r> r> rot r> swap >r >r >r >r -4 +loop
rp0 oldrp@ to traceon ;
code @nesxt ( -- a3 a4 )
np sp -) move, nx sp -) move, next;
: rdump ( -- \ display return stack )
rstackcopy rp0 oldrp@ - <rdump> ;
: tracing ( -- )
edde if tracetotext else tracetoscr then ( be smart about where to display )
cr ctrace
if ." code" codetoken
else tracepointer 0 +table - 4 /
then dup . dup exa invoc name name cr @nesxt
dup ['] tracenext exa = if ['] tracenext name else
dup ['] triggernext exa = if ['] triggernext name else
." normalnext" then then drop
dup ['] tracenest exa = if ['] tracenest name else
dup ['] triggernest exa = if ['] triggernest name else
." normalnest" then then drop ;
: <trace> ( | token -- | setup token to be traced )
stepping on ( *** )
dup exa w@ ['] <trace> exa w@ =
if hl-trace
else dup swab 0ff and ?int
if drop
else traceiling off c-trace
then then tracing ;
: trace ( name | -- | setup name to be traced )
' <trace> ;
: try ( name | -- | setup name to be traced )
c' ['] temp +table ! ['] temp <trace> temp ;
( vl ) tdeactivate debug
( MNP communications code )
( 2.6 Utility words
##################################################################### )
( CRC16 generation )
code crc16table nx ) jsr, ;c
( | the table for CRC16 generation )
0 w, 1020 w, 2040 w, 3060 w, 4080 w, 50A0 w, 60C0 w, 70E0 w,
8100 w, 9120 w, A140 w, B160 w, C180 w, D1A0 w, E1C0 w, F1E0 w,
1221 w, 201 w, 3261 w, 2241 w, 52A1 w, 4281 w, 72E1 w, 62C1 w,
9321 w, 8301 w, B361 w, A341 w, D3A1 w, C381 w, F3E1 w, E3C1 w,
2442 w, 3462 w, 402 w, 1422 w, 64C2 w, 74E2 w, 4482 w, 54A2 w,
A542 w, B562 w, 8502 w, 9522 w, E5C2 w, F5E2 w, C582 w, D5A2 w,
3663 w, 2643 w, 1623 w, 603 w, 76E3 w, 66C3 w, 56A3 w, 4683 w,
B763 w, A743 w, 9723 w, 8703 w, F7E3 w, E7C3 w, D7A3 w, C783 w,
4884 w, 58A4 w, 68C4 w, 78E4 w, 804 w, 1824 w, 2844 w, 3864 w,
C984 w, D9A4 w, E9C4 w, F9E4 w, 8904 w, 9924 w, A944 w, B964 w,
5AA5 w, 4A85 w, 7AE5 w, 6AC5 w, 1A25 w, A05 w, 3A65 w, 2A45 w,
DBA5 w, CB85 w, FBE5 w, EBC5 w, 9B25 w, 8B05 w, BB65 w, AB45 w,
6CC6 w, 7CE6 w, 4C86 w, 5CA6 w, 2C46 w, 3C66 w, C06 w, 1C26 w,
EDC6 w, FDE6 w, CD86 w, DDA6 w, AD46 w, BD66 w, 8D06 w, 9D26 w,
7EE7 w, 6EC7 w, 5EA7 w, 4E87 w, 3E67 w, 2E47 w, 1E27 w, E07 w,
FFE7 w, EFC7 w, DFA7 w, CF87 w, BF67 w, AF47 w, 9F27 w, 8F07 w,
9108 w, 8128 w, B148 w, A168 w, D188 w, C1A8 w, F1C8 w, E1E8 w,
1008 w, 28 w, 3048 w, 2068 w, 5088 w, 40A8 w, 70C8 w, 60E8 w,
8329 w, 9309 w, A369 w, B349 w, C3A9 w, D389 w, E3E9 w, F3C9 w,
229 w, 1209 w, 2269 w, 3249 w, 42A9 w, 5289 w, 62E9 w, 72C9 w,
B54A w, A56A w, 950A w, 852A w, F5CA w, E5EA w, D58A w, C5AA w,
344A w, 246A w, 140A w, 42A w, 74CA w, 64EA w, 548A w, 44AA w,
A76B w, B74B w, 872B w, 970B w, E7EB w, F7CB w, C7AB w, D78B w,
266B w, 364B w, 62B w, 160B w, 66EB w, 76CB w, 46AB w, 568B w,
D98C w, C9AC w, F9CC w, E9EC w, 990C w, 892C w, B94C w, A96C w,
588C w, 48AC w, 78CC w, 68EC w, 180C w, 82C w, 384C w, 286C w,
CBAD w, DB8D w, EBED w, FBCD w, 8B2D w, 9B0D w, AB6D w, BB4D w,
4AAD w, 5A8D w, 6AED w, 7ACD w, A2D w, 1A0D w, 2A6D w, 3A4D w,
FDCE w, EDEE w, DD8E w, CDAE w, BD4E w, AD6E w, 9D0E w, 8D2E w,
7CCE w, 6CEE w, 5C8E w, 4CAE w, 3C4E w, 2C6E w, 1C0E w, C2E w,
EFEF w, FFCF w, CFAF w, DF8F w, AF6F w, BF4F w, 8F2F w, 9F0F w,
6EEF w, 7ECF w, 4EAF w, 5E8F w, 2E6F w, 3E4F w, E2F w, 1E0F w,
code crc16 ( cur data -- crc )
sp )+ d0 move, sp )+ d3 move, tc' crc16table #n a1 move, 8 #n d3 .w ror,
d0 d3 .b eor, d3 d1 .b move, ff #n d1 andi, 1 #n d1 .w lsl,
a1 d1 0 xw)d d1 .w move, d1 d3 .w eor,
d3 sp -) move, next;
( Debugging support words )
: dbs
( n1 string -> | if n1 > dbug.lev, type string. For most usage, n1 = 5 means
debug enabled, n1 = 3 means debug disabled )
?stack
if ( stack NG ! )
.s space ." !!! dbs/stack err" cr
then
rot dbug.lev >
if
type
else
2drop
then
;
: dbsc
dbs
dv2 dbug.lev >
if
cr
then
;
: dbk
( n1 n2 string -> | if n2 > dbug.lev, type string, print value n1. For most
usage, n2 = 5 means debug enabled, n2 = 3 means debug disabled )
?stack
if ( stack NG ! )
.s space ." !!! dbk/stack err" cr
then
>r >r ( string to return stk )
dbug.lev >
if
r> r> type space
.
else
drop
r> r>
2drop
then
;
: dbkc
dbk
dv2 dbug.lev >
if
cr
then
;
: rcvb_read
( | DB reads the receive buffer. Uses own pointer + does not disturb
buffer contents or any on-going operations )
cr
dv2 " rcvbuff contents -- " dbsc
local dbptr
local fsize
rcvbuff dbptr to
dbptr c@ 1 dbptr +to ( get lo byte, frame size )
dbptr c@ + fsize to ( get hi byte, frame size, add to lo byte )
1 fsize +to ( fudge to get last cell )
1 dbptr +to
begin
dbptr c@ . space 1 dbptr +to
rcvbuff fsize + dbptr <
if ( ptr beyond fsize, exit )
cr exit
then
again
;
: dbn
( | do a dbs with lo dbug level and null string, just to get stack check )
1 " " dbs
;
: stk_db
( | show the top of the stack )
." stack top =" dup . cr
;
: clear_flags
( | clear the flags for clean up )
asap.req off
break.req off
connect.ind off
data.in off
data.out off
data.up off
discon.req off
endflag.req off
gotframe off
shutup off
start.lt off
;
: clean_up
( | cleanup and housekeeping )
dv2 ( " clean_up") dbsc
clear_flags
0 fr.timer to
0 la.timer to
0 ln.timer to
0 lt.timer to
0 lr.init.timer to
0 frame.stat to
0 trans.stat to
0 hdrlen to
0 pdutyp to
0 ln.retry.ctr to
0 lr.retry.ctr to
0 lt.retry.ctr to
0 sflg.retry.ctr to
0 pdutyp to
0 trans.stat to
;
: reset_all
( | cleanup and housekeeping done when entering idle state )
dv2 ( " reset_all") dbsc
clean_up
1 local.cred to
data.in off
data.out off
break.req off
connect.ind off
no.xmit.ind off
st.idle state to
;
: cal_crc
( | Calculate CRC for the current character )
curval curchar crc16 ( CRC calculation )
curval to
;
: xmp_adv
( c -> | load next transmit buffer cell )
xmtptr c! 1 xmtptr +to
;
: ld_char
( c -> | put the char in the next transmit buffer cell, doing CRC )
curchar to cal_crc curchar xmp_adv
;
: shp_adv
( c -> | load next shutup buffer cell )
shtptr c! 1 shtptr +to
;
: lds_char
( c -> | put the char in the next shutup buffer cell, doing CRC )
curchar to cal_crc curchar shp_adv
;
( : clr_stack
# | empty the stack #
local count
depth count to
count dv2 " clr_stack/depth=" dbkc
begin
count 0=
if
exit
then
drop
-1 count to
again
; )
: build_lr_skel
( | build a skeleton LR in xmitbuff )
dv2 " build LR skel" dbsc
curstrt curval to ( initialize CRC current value )
xmitbuff xmtptr to ( reset pointer )
SYN xmp_adv ( load the start flag, not included in CRC )
DLE xmp_adv
STX xmp_adv
17 ld_char ( load LI. There are 17 hex octets in the LR )
1 ld_char ( load LR functional type code )
lr.prot.lvl ld_char ( load protocol level indicator, may be changed )
( note - the serial number below is the no-checking value )
1 ld_char ( load serial number parm code )
6 ld_char ( load serial number parm length )
1 ld_char ( load serial number seq. number 1st octet )
0 ld_char ( load serial number seq. number 2nd octet )
0 ld_char ( load serial number seq. number 3rd octet )
0 ld_char ( load serial number checksum )
0 ld_char ( load serial number seq. number 4th octet )
FF ld_char ( load serial number series number )
2 ld_char ( load service class parm code )
1 ld_char ( load service class parm length )
lr.svc.clas ld_char ( load service class, may be changed )
3 ld_char ( load credit allocation parm code )
1 ld_char ( load credit allocation parm length )
lr.crd.allo ld_char ( load credit allocation, always 1 for stop-and-wait )
( note - max data size set to hex 40 to get 256 octet max size, see
data phase optimization parm below )
4 ld_char ( load max data size parm code )
2 ld_char ( load max data size parm length )
lr.mdata.lo ld_char ( load max data size low order octet )
lr.mdata.hi ld_char ( load max data size high order octet )
( note - data phase optimization and max data size above must be set
as shown for 256 octet data size )
8 ld_char ( load data phase optimization parm code )
1 ld_char ( load data phase optimization parm length )
lr.data.ph ld_char ( load data phase optimization value, size of 256, fixed
field LT and LA, may be changed )
DLE xmp_adv ( precede the ETX with a DLE, not in CRC )
ETX ld_char
curval 8 shr ( shift the MS byte of FCS into the LS byte )
xmp_adv ( put it in the buffer )
curval xmp_adv ( put the LS byte of FCS in the buffer )
xmtptr xmitbuff - xmt.count to ( save the char count )
xmitbuff xmtptr to ( reset pointer to beginning )
;
: build_ld_skel
( | build a skeleton LD )
dv2 " build LD skel" dbsc
curstrt curval to ( initialize CRC current value )
xmitbuff xmtptr to ( reset pointer )
SYN xmp_adv ( load the start flag, not included in CRC )
DLE xmp_adv
STX xmp_adv
4 ld_char ( load LI. there are 4 octets in the LD )
2 ld_char ( load LD functional type code )
1 ld_char ( load reason code parm code )
1 ld_char ( load reason code parm length )
ld.reason ld_char ( load reason code parm value )
DLE xmp_adv ( precede the ETX with a DLE, not in CRC )
ETX ld_char
curval 8 shr ( shift the MS byte of FCS into the LS byte )
xmp_adv ( put it in the buffer )
curval xmp_adv ( put the LS byte of FCS in the buffer )
xmtptr xmitbuff - xmt.count to ( save the char count )
xmitbuff xmtptr to ( reset pointer )
;
: build_ln
( | build an LN )
dv2 " build LN" dbsc
curstrt curval to ( initialize CRC current value )
xmitbuff xmtptr to ( reset pointer )
SYN xmp_adv ( load the start flag, not included in CRC )
DLE xmp_adv
STX xmp_adv
DLE xmp_adv ( precede the ETX with a DLE, not in CRC )
ETX ld_char
curval 8 shr ( shift the MS byte of FCS into the LS byte )
xmp_adv ( put it in the buffer )
curval xmp_adv ( put the LS byte of FCS in the buffer )
xmtptr xmitbuff - xmt.count to ( save the char count )
xmitbuff xmtptr to ( reset pointer )
;
: build_lna
( | build an LNA )
dv2 " build LNA" dbsc
curstrt curval to ( initialize CRC current value )
xmitbuff xmtptr to ( reset pointer )
SYN xmp_adv ( load the start flag, not included in CRC )
DLE xmp_adv
STX xmp_adv
4 ld_char ( load LI. there are 4 octets in the LNA )
7 ld_char ( load LNA functional type code )
1 ld_char ( load seq number parm code )
1 ld_char ( load seq number parm length )
rem.ln.seqn ld_char ( load seq number parm value )
DLE xmp_adv ( precede the ETX with a DLE, not in CRC )
ETX ld_char
curval 8 shr ( shift the MS byte of FCS into the LS byte )
xmp_adv ( put it in the buffer )
curval xmp_adv ( put the LS byte of FCS in the buffer )
xmtptr xmitbuff - xmt.count to ( save the char count )
xmitbuff xmtptr to ( reset pointer )
;
: build_laf
( | build a fixed field LA )
dv2 " build fixed field LA" dbsc
curstrt curval to ( initialize CRC current value )
xmitbuff xmtptr to ( reset pointer )
SYN xmp_adv ( load the start flag, not included in CRC )
DLE xmp_adv
STX xmp_adv
3 ld_char ( load LI. there are 7 octets in the LA )
5 ld_char ( load LA functional type code )
local.seqn ld_char ( load seq number parm value )
local.cred ld_char ( load credit parm value )
DLE xmp_adv ( precede the ETX with a DLE, not in CRC )
ETX ld_char
curval 8 shr ( shift the MS byte of FCS into the LS byte )
xmp_adv ( put it in the buffer )
curval xmp_adv ( put the LS byte of FCS in the buffer )
xmtptr xmitbuff - xmt.count to ( save the char count )
xmitbuff xmtptr to ( reset pointer )
;
: build_las
( | build a fixed field LA to be sent to 'shutup' the remote guy )
dv2 " build fixed field shutup LA" dbsc