```// CALC.sr

get "ST.DF";
get "CH.DF";
get "CALC.DF";

// Outgoing Procedures

external	[
RealSub;
RealMult;
RealDiv;
RealIntExponent;
Normalize;
RealFromInt;
RealFromSt;
StFromReal;
WordSizeReal;
]

// Outgoing Statics

external	[
cdigitpoint;
frealmode;
];

// Incoming Procedures

external	[
mult;
divmod;
umax;
umin;
move;
stget;
stsize;
stput;
stcopy;
sbwsize;
SbSetSize;
stappend;
stnum;
stcompare;
errhlt;
]

// Local Statics

static	[
cdigitpoint = 2;
frealmode = frealfixed;
];

// C H G E T R E A L

let ChGetReal(r, cp) = (cp ls 0 % cp ge r>>REAL.cch ? \$0,
r>>REAL.ch ↑ cp);
// end ChGetReal

// C H M A P

and ChMap(ch) = valof
[
if ch ge \$: & ch le \$? then resultis ch + 7;
if ch ge \$A & ch le \$F then resultis ch - 7;
resultis ch;
] // end ChMap

// D I G I T A D D

and DigitAdd(a, b, cin, pcout) = valof
[
let sum = a + b + cin - 2 * \$0;
if sum ge vintradix+\$0 then
[
rv pcout = \$1;
resultis sum - vintradix;
];
rv pcout = \$0;
resultis sum;
] // end DigitAdd

// D I G I T M U L T

let Digitmult(a, b, cin, pcout) = valof
[
let prod = mult(a-\$0, b-\$0) + cin - \$0;
rv pcout = divmod(prod, vintradix, lv prod) + \$0;
resultis prod + \$0;
] // end Digitmult

// M A G N I T U D E A D D

and MagnitudeAdd(rsum, ra, rb) = valof
[
let expa = ra>>REAL.exponent;
let expb = rb>>REAL.exponent;
let dcpa = 1;
let dcpb = 1;
test expa ls expb ifso dcpa = (expb - expa) + 1;
ifnot dcpb = (expa - expb) + 1;
let ccha = ra>>REAL.cch;
let cchb = rb>>REAL.cch;
let cchsum = umin(umax(ccha+dcpa, cchb+dcpb), cchmaxreal);
let carry = \$0;
for cp = cchsum-1 to 0 by -1 do
[
rsum>>REAL.ch ↑ cp = DigitAdd(
ChGetReal(ra, cp - dcpa), ChGetReal(rb, cp - dcpb),
carry, lv carry);
];
rsum>>REAL.exponent = expa + dcpa;
rsum>>REAL.cch = cchsum;
resultis Normalize(rsum);
] // end MagnitudeAdd

// M A G N I T U D E S U B

and MagnitudeSub(rdiff, ra, rb) = valof
[
let expa = ra>>REAL.exponent;
let expb = rb>>REAL.exponent;
let dcpa = 0;
let dcpb = 0;
test expa ls expb ifso dcpa = expb - expa;
ifnot dcpb = expa - expb;
let ccha = ra>>REAL.cch;
let cchb = rb>>REAL.cch;
let cchdiff = umin(umax(ccha+dcpa, cchb+dcpb), cchmaxreal);
let chradix = vintradix + \$0 - 1;
let carry = \$1;
for cp = cchdiff-1 to 0 by -1 do
[
rdiff>>REAL.ch ↑ cp = DigitAdd(
ChGetReal(ra, cp - dcpa),
chradix + \$0 - ChGetReal(rb, cp - dcpb),
carry, lv carry);
];
rdiff>>REAL.exponent = expa + dcpa;
rdiff>>REAL.cch = cchdiff;
resultis Normalize(rdiff);
] // end MagnitudeSub

// F M A G N I T U D E C O M P A R E

and FMagnitudeCompare(ra, rb) = valof
[
let expa = ra>>REAL.exponent;
let expb = rb>>REAL.exponent;
if expa gr expb then resultis 1;
if expa ls expb then resultis -1;
resultis stcompare(lv ra>>REAL.asb, lv rb>>REAL.asb);
] // end FMagnitudeCompare

// R E A L A D D

and RealAdd(rsum, ra, rb) = valof
[
let fsigna = ra>>REAL.fsign;
let fsignb = rb>>REAL.fsign;
if not fsigna & not fsignb then
[
rsum>>REAL.fsign = false;
resultis MagnitudeAdd(rsum, ra, rb);
];
if fsigna & fsignb then
[
rsum>>REAL.fsign = true;
resultis MagnitudeAdd(rsum, ra, rb);
];
let fcompare = FMagnitudeCompare(ra, rb) ge 0;
rsum>>REAL.fsign = fsigna eqv fcompare;
if fcompare then resultis MagnitudeSub(rsum, ra, rb);
resultis MagnitudeSub(rsum, rb, ra);
] // end RealAdd

// R E A L S U B

and RealSub(rdiff, ra, rb) = valof
[
let fsigna = ra>>REAL.fsign;
let fsignb = rb>>REAL.fsign;
if not fsigna & fsignb then
[
rdiff>>REAL.fsign = false;
resultis MagnitudeAdd(rdiff, ra, rb);
];
if fsigna & not fsignb then
[
rdiff>>REAL.fsign = true;
resultis MagnitudeAdd(rdiff, ra, rb);
];
let fcompare = FMagnitudeCompare(ra, rb) ge 0;
rdiff>>REAL.fsign = fsigna eqv fcompare;
if fcompare then resultis MagnitudeSub(rdiff, ra, rb);
resultis MagnitudeSub(rdiff, rb, ra);
] // end RealSub

// R E A L M U L T

and RealMult(rprod, ra, rb) = valof
[
let trprod = vec cwmaxreal;
let ccha = ra>>REAL.cch;
let cchb = rb>>REAL.cch;
let cchprod = umin(ccha + cchb, cchmaxreal);
for cpprod = 0 to cchprod-1 do trprod>>REAL.ch ↑ cpprod = \$0;
for cpb = cchb-1 to 0 by -1 do
[
let addcarry = \$0;
let multcarry = \$0;
for cpa = ccha-1 to 0 by -1 do
[
let cpprod = cpa + cpb + 1;
if cpprod ge cchprod then loop;
trprod>>REAL.ch ↑ cpprod = DigitAdd(
trprod>>REAL.ch ↑ cpprod,
Digitmult(ra>>REAL.ch ↑ cpa,
rb>>REAL.ch ↑ cpb,
multcarry, lv multcarry),
];
trprod>>REAL.ch ↑ cpb = DigitAdd(
trprod>>REAL.ch ↑ cpb,
multcarry,
];
trprod>>REAL.cch = cchprod;
trprod>>REAL.exponent = ra>>REAL.exponent + rb>>REAL.exponent + 1;
trprod>>REAL.fsign = ra>>REAL.fsign xor rb>>REAL.fsign;
move(Normalize(trprod), rprod, WordSizeReal(trprod));
resultis rprod;
] // end RealMult

// R E A L D I V

and RealDiv(rquo, ra, rb, cchquo; numargs carg) = valof
[
let trquo = vec cwmaxreal;
let ccha = ra>>REAL.cch;
let cchb = rb>>REAL.cch;
if cchb eq 0 then resultis realnil;
if carg ls 4 % cchquo eq 0 then cchquo = cchmaxreal;
cchquo = umin(cchquo, cchmaxreal);
let chradix = vintradix + \$0 - 1;
SbSetSize(lv trquo>>REAL.asb, 0);
stcopy(lv trquo>>REAL.asb, lv ra>>REAL.asb);
for cpquo = ccha to cchquo-1 do trquo>>REAL.ch ↑ cpquo = \$0;
let chfirst = \$0;
for cpquo = 0 to cchquo-1 do
[
let chquo = \$0;
let carry = \$1;
while carry eq \$1 do
[
for cpb = cchb-1 to 0 by -1 do
[
let tcp = cpquo + cpb;
if tcp ge cchquo then loop;
trquo>>REAL.ch ↑ tcp = DigitAdd(
trquo>>REAL.ch ↑ tcp,
chradix + \$0 - rb>>REAL.ch ↑ cpb,
carry, lv carry);
];
chfirst = DigitAdd(chfirst, chradix, carry, lv carry);
chquo = chquo + 1;
];
for cpb = cchb-1 to 0 by -1 do
[
let tcp = cpquo + cpb;
if tcp ge cchquo then loop;
trquo>>REAL.ch ↑ tcp = DigitAdd(
trquo>>REAL.ch ↑ tcp,
rb>>REAL.ch ↑ cpb,
carry, lv carry);
];
chfirst = trquo>>REAL.ch ↑ cpquo;
trquo>>REAL.ch ↑ cpquo = chquo - 1;
];
trquo>>REAL.cch = cchquo;
trquo>>REAL.exponent = ra>>REAL.exponent - rb>>REAL.exponent;
trquo>>REAL.fsign = ra>>REAL.fsign xor rb>>REAL.fsign;
move(Normalize(trquo), rquo, WordSizeReal(trquo));
resultis rquo;
] // end RealDiv

// R E A L R A D I X C O N V E R T

[
let tr = vec cwmaxreal;
rresult>>REAL.fsign = false;
rresult>>REAL.exponent = 0;
SbSetSize(lv rresult>>REAL.asb, 0);
for cp = 0 to r>>REAL.cch - 1 do
RealFromInt(tr, r>>REAL.ch ↑ cp - \$0));
resultis RealMult(rresult, rresult,
RealIntExponent(tr, rradix, r>>REAL.exponent + 1 - r>>REAL.cch));
] // end RealRadixConvert

// R E A L I N T E X P O N E N T

and RealIntExponent(rresult, r, int) = valof
[
let fsign = false;
if int ls 0 then
[
fsign = true;
int = -int;
];
let rone = table
[
0;
0;
1 lshift 8 + \$1;
];
move(rone, rresult, 3);
let tr = vec cwmaxreal;
move(r, tr, WordSizeReal(r));
[
if (int & 1) ne 0 then RealMult(rresult, rresult, tr);
int = int rshift 1;
if int eq 0 then break;
RealMult(tr, tr, tr);
] repeat;
resultis (not fsign ? rresult,
RealDiv(rresult, rone, rresult));
] // end RealIntExponent

// N O R M A L I Z E

and Normalize(r) = valof
[
let cch = r>>REAL.cch;
let sb = lv r>>REAL.asb;
let cpfirst = 0;
while cpfirst ls cch do
[
if sb>>SB.ch ↑ cpfirst ne \$0 then break;
cpfirst = cpfirst + 1;
];
let cplast = cch-1;
while cplast ge cpfirst do
[
if sb>>SB.ch ↑ cplast ne \$0 then break;
cplast = cplast - 1;
];
if cpfirst gr cplast then
[
r>>REAL.fsign = false;
r>>REAL.exponent = 0;
r>>REAL.asb = 0;
resultis r;
];
let cchnew = cplast+1 - cpfirst
if cchnew eq cch then resultis r;
for cp = cpfirst to cplast do
sb>>SB.ch ↑ (cp-cpfirst) = sb>>SB.ch ↑ cp
sb>>SB.cch = cchnew
r>>REAL.exponent = r>>REAL.exponent - cpfirst;
resultis r;
] // end Normalize

// R E A L F R O M I N T

and RealFromInt(r, int) = valof
[
r>>REAL.fsign = false;
if int ls 0 then
[
r>>REAL.fsign = true;
int = -int;
];
SbSetSize(lv r>>REAL.asb, 0);
stnum(lv r>>REAL.asb, int, vintradix);
r>>REAL.exponent = r>>REAL.cch - 1;
resultis Normalize(r);
] // end RealFromInt

// R E A L F R O M S T

and RealFromSt(r, st) = valof
[
let cp = 0;
let state = 0;
let cpreal = 0;
let cppoint = cpnil;
let fexpsign = false;
let exponent = 0;
let chmax = vintradix + \$0;
let ch = nil;
while valof [ ch = stget(st, cp); cp = cp+1; resultis ch ] ne chnil do
teststate:
switchon state into
[
case 0:	state = 1;
r>>REAL.fsign = ch eq \$-;
if ch eq \$+  % ch eq \$- then loop;
if ChMap(ch) ge \$0 & ChMap(ch) ls chmax
% ch eq \$. then goto teststate;
resultis realnil;

case 1:	if ch eq \$. then
[
cppoint = cpreal;
state = 2;
loop;
];
if ch eq \$↑ then
[
cppoint = cpreal;
state = 3;
loop;
];
ch = ChMap(ch);
if ch ls \$0 % ch ge chmax then resultis realnil;
if cpreal ls cchmaxreal then
[
r>>REAL.ch ↑ cpreal = ch;
cpreal = cpreal+1;
];
loop;

case 2:	if ch eq \$↑ then
[
state = 3;
loop;
];
ch = ChMap(ch);
if ch ls \$0 % ch ge chmax then resultis realnil;
if cpreal ls cchmaxreal then
[
r>>REAL.ch ↑ cpreal = ch;
cpreal = cpreal+1;
];
loop;

case 3:	state = 4;
fexpsign = ch eq \$-;
if ch eq \$+ % ch eq \$- then loop;
if ChMap(ch) ge \$0 & ChMap(ch) ls chmax then
goto teststate;
resultis realnil;

case 4:	ch = ChMap(ch);
if ch ls \$0 % ch ge chmax then resultis realnil;
exponent = mult(exponent, 10) + ch-\$0;
if exponent ls 0 then resultis realnil;
loop;
];
if state eq 0 % state eq 3 then resultis realnil;
SbSetSize(lv r>>REAL.asb, cpreal);
exponent = (fexpsign ? -exponent, exponent);
r>>REAL.exponent = (cppoint eq cpnil ? cpreal-1, exponent + cppoint-1);
resultis Normalize(r);
] // end RealFromSt

// S T F R O M R E A L

and StFromReal(st, r, cchst; numargs carg) = valof
[
if carg ls 3 then cchst = -1
let tr = vec cwmaxreal;
let tfrealmode = frealmode;
let tcdigitpoint = cdigitpoint;
let cppoint = nil;
let cpmax = nil;
let cpreal = nil;
round:
let rround = vec 3;
rround>>REAL.exponent = selecton tfrealmode into
[
case frealfixed:	0
case frealsci:	r>>REAL.exponent
case frealeng:	mult(divmod(r>>REAL.exponent + #100001, 3, lv cppoint), 3) - #100001
] - (tcdigitpoint + 1);
rround>>REAL.asb = (r>>REAL.cch eq 0 ? 0, 1 lshift 8 + vintradix rshift 1 + \$0);
let exp = tr>>REAL.exponent;
if tfrealmode eq frealeng then
exp = mult(divmod(exp + #100001, 3, lv cppoint), 3) - #100001
let cchreal = tr>>REAL.cch;
let sbexp = vec 4;
sbexp>>SB.ch ↑ 0 = \$↑;
SbSetSize(sbexp, 1);
let tsb = vec 4;
SbSetSize(tsb, 0);
switchon tfrealmode into
[
case frealfixed:
sbexp = "";
cppoint = (exp ls 0 ? 1, exp+1);
cpmax = cppoint + (tcdigitpoint le 0 ? 0, tcdigitpoint + 1);
cpreal = (exp ge 0 ? 0, exp);
endcase;

case frealsci:
stappend(sbexp, stnum(tsb, exp));
cppoint = 1;
cpmax = tcdigitpoint + 2;
cpreal = 0;
endcase;

case frealeng:
stappend(sbexp, stnum(tsb, exp));
cppoint = cppoint + 1;
cpmax = cppoint + tcdigitpoint + 1;
cpreal = 0;
endcase;
];
let cchtotal = cpmax + stsize(sbexp) + (r>>REAL.fsign ? 1, 0);
cchst = umin(cchst, cchtotal)
// if rv st eq 1 then cchst = st>>ST.cch;
let dcch = cchst - cchtotal;
if dcch ls 0 then
[
if tfrealmode ne frealsci then
[
tfrealmode = frealsci;
goto round;
];
tcdigitpoint = tcdigitpoint + dcch;
if tcdigitpoint ge 0 then goto round;
for tcp = 0 to cchst-1 do
stput(st, tcp, \$**);
// 	if rv st ne 1 then
SbSetSize(st, cchst);
resultis st;
];
let cp = 0;
while cp ls dcch do
[
stput(st, cp, chblank);
cp = cp + 1;
];
if r>>REAL.fsign then
[
stput(st, cp, \$-);
cp = cp + 1;
];
let dcp = 0;
while dcp ls cpmax do
[
if dcp eq cppoint then
[
stput(st, cp+dcp, \$.);
dcp = dcp + 1;
loop;
];
stput(st, cp+dcp, ChMap(ChGetReal(tr, cpreal)));
dcp = dcp + 1;
cpreal = cpreal + 1;
];
let dcp = cp+cpmax
for tcp = 0 to stsize(sbexp)-1 do
stput(st, tcp+dcp, stget(sbexp, tcp))
// if rv st ne 1 then
SbSetSize(st, cchst);
resultis st;
] // end StFromReal

// W O R D S I Z E R E A L

and WordSizeReal(r) = (r>>REAL.cch rshift 1)+offasbreal+1;
// end WordSizeReal

```