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.

5321 lines
208 KiB

8 months ago
( 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,