CAT/C1SC240.TXT

( 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,