{linesize 256}
{library}
{list off}
{Last modification <840120.1607>}
{COPYRIGHT (c) 1984 WEITEK INC}
{range off{}
{
Known Bugs:
If the remainder is zero, its sign should be that of the dividend
Extended has two flavors of the smallest exponent
Unnormal zero's don't add properly
Extended not well tested
This program contains IEEE-compatable arithmetic
routines. They are externally callable, using
single, double, or extended precision.
Entry point Operation
----------- ---------
ADDS Add, single precision
ADDD Add, double precision
ADDE Add, extended precision
SUBS Subtract, single precision
SUBD Subtract, double precision
SUBE Subtract, extended precision
MULS MULTIPLY, single precision
MULD MULTIPLY, double precision
MULE MULTIPLY, extended precision
DIVS Divide, single precision
DIVD Divide, double precision
DIVE Divide, extended precision
* REMS Remainder, single precision
* REMD Remainder, double precision
* REME Remainder, extended precision
* SQRTS Square root, single precision
* SQRTD Square root, double precision
* SQRTE Square root, extended precision
* CONSD Convert single to double precision
* CONSE Convert single to extended precision
* CONSH Convert single to 16 bit integer
* CONSI Convert single to 32 bit integer
* CONDS Convert double to single precision
* CONDE Convert double to extended precision
* CONDH Convert double to 16 bit integer
* CONDI Convert double to 32 bit integer
* CONES Convert extended to single precision
* CONED Convert extended to double precision
* CONEH Convert extended to 16 bit integer
* CONEI Convert extended to 32 bit integer
* CONIS Convert 32 bit integer to single
* CONID Convert 32 bit integer to double
* CONIE Convert 32 bit integer to extended
* CONIH Convert 32 bit integer to 16 bit integer
* CONHS Convert 16 bit integer to single
* CONHD Convert 16 bit integer to double
* CONHE Convert 16 bit integer to extended
* CONHI Convert 16 bit integer to 32 bit integer
INTS Integerize, single precision
INTD Integerize, double precision
INTE Integerize, extended precision
* SDECBIN Convert decimal string to single precision binary
* DDECBIN Convert decimal string to double precision binary
* EDECBIN Convert decimal string to extended precision binary
SCOMPARE Compare, single precision
DCOMPARE Compare, double precision
ECOMPARE Compare, extended precision
* SBINDEC Convert single precision binary to decimal string
* DBINDEC Convert double precision binary to decimal string
* EBINDEC Convert extended precision binary to decimal string
* COPYSIGN Op1 gets op2's sign
* SCALB Adds N to X's exponent
* LOGB Returns unbiased exponent of X
* NEXTAFTER Next representable X in direction of Y
* FINITE True if finite
* ISNAN True if NaN
* UNORDERED True if unordered
* CLASS 1=tNaN, 2=ntNaN, 3=-inf, 4=-norm, 5=-unnorm
6=-denorm, 7=-0, 8=+0, 9=+denorm, 10=+unnorm,
11=+norm, 12=+inf
* Not finished yet
}
{page}
{heap 0}
{recursive off}
{title 'ARITH'}
{SUBPROGRAM}
Program ARITH(input,output){};
{visible off} {fix!}
label 99;
{Last mod <820402.1224>}
const mant←bits = 112; {Max # of mantissa bits, any form}
exp←bits = 15; {Max # of exponent bits, any form}
max←num←bits = 128; {1+exp←bits+mant←bits}
mant←bits←m1 = 111; {mant←bits-1}
mant←bits←p1 = 113; {mant←bits+1}
mant←bits←p2 = 114; {mant←bits+2}
{!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
single←exp←bits ={3 { 4} 8 {Number of exponent bits, single} ;
single←mant←bits ={3 { 5} 24 {Number of mantissa bits, single} ;
single←min←exp ={-2{-6}-126 {Minimum exponent, single} ;
single←max←exp ={3 { 7} 127 {Maximum exponent, single} ;
single←bias ={3 { 7} 127 {Bias, single} ;
double←exp←bits = 11; {Number of exponent bits, double}
double←mant←bits = 53; {Number of mantissa bits, double}
double←min←exp = -1022; {Minimum exponent, double}
double←max←exp = 1023; {Maximum exponent, double}
double←bias = 1023; {Bias, double}
extended←exp←bits = 15; {Number of exponent bits, extended}
extended←mant←bits= 112; {Number of mantissa bits, extended}
extended←min←exp = -16383; {Minimum exponent, extended}
extended←max←exp = 16383; {Maximum exponent, extended}
extended←bias = 16383; {Maximum exponent, extended}
nstringchars = 30; {Max number of chars in a string}
debug = false;
type bit = 0..1;
halfint = -32768..32767;
SHORTREAL = packed array[1..32] of bit;
LONGREAL = packed array[1..64] of bit;
veryLONGREAL = packed array[1..128] of bit; {extended prec, extern}
mant←array = packed array[1..mant←bits] of bit; {mantissa}
number = record {Internal form used for all numbers}
sign: bit;
expon: integer; {unbiased}
mant: mant←array; {with explicit leading bit}
end;
formattype = (single, double, extended);
trap←setting = (disabled, enabled);
undermodetype = (warning, normalizing);
infinitytype = (projective, affine);
roundtype = (rn, rp, rz, rm);
expbitstype = single←exp←bits..extended←exp←bits;
error←indicator = (off,on);
error←flag = error←indicator;
string = packed array[1..nstringchars] of char;
string5 = packed array[1..5] of char; {for segment loader}
cc = (lt,eq,gt,un); {Condition Codes}
twooperandtype = (a,b,c,d,e,f,g,h,i,X,Y,M);
oneoperandtype = (pmzero,W,pminf,NaN);
modestype = packed record
invalid←trap: trap←setting;
divbyzero←trap: trap←setting;
overflow←trap: trap←setting;
underflow←trap: trap←setting;
inexact←trap: trap←setting;
check←underflow←before←rounding: boolean;
under←mode: undermodetype;
infinity←mode: infinitytype;
round←mode: roundtype
end;
indicstype = packed record
divbyzero←indic: error←indicator; {indics cleared}
invalid←indic: error←indicator; {before each }
overflow←indic: error←indicator; {operation }
underflow←indic: error←indicator;
inexact←indic: error←indicator;
divbyzero←flag: error←flag; {flags are}
invalid←flag: error←flag; {sticky }
overflow←flag: error←flag;
underflow←flag: error←flag;
inexact←flag: error←flag
end;
gvarstype = record
format: formattype;
mant←prec: 2..mant←bits; {# of mantissa bits}
min←exp: integer; {minimum exponent, unbiased}
max←exp: integer; {maximum exponent, unbiased}
bias: integer;
expbits: expbitstype; {# of exponent bits}
guard,round,sticky,carry: bit
end;
access = (a1,a2,a3,a4,a5,a6);
pervert = record
case access of
a1: (I:integer);
a2: (H1,H2,H3,H4:integer);
a3: (R:SHORTREAL);
a4: (L:LONGREAL);
a5: (VL:veryLONGREAL);
a6: (B:packed array [1..max←num←bits] of bit)
end;
VAR FUBAR:TEXT;
procedure halt(halt←code: integer);
begin
writeln ('fatal error: code=',halt←code);
goto 99;
end;
function XOR(a,b:bit):bit; {Exclusive OR}
begin
if a=b then xor:=0 else xor:=1;
end;
{subtitle 'ZERO functions',page}
procedure ZERO(var result: number; var{} gvars:gvarstype);
{Returns Normal Zero, undefined sign}
var I: 1..mant←bits;
begin
with gvars do begin
result.expon:=min←exp; {exponent is format's minimum}
for i:=1 to mant←prec do result.mant[i]:=0
end
end;
procedure PLUSZERO(var result: number; var{} gvars:gvarstype);
{Returns Positive Normal Zero}
var I: 1..mant←bits;
begin
zero (result, gvars);
result.sign:=0 {0=positive}
end;
procedure MINUSZERO(var result: number; var{} gvars:gvarstype);
{Returns Negative Normal Zero}
var I: 1..mant←bits;
begin
zero (result, gvars);
result.sign := 1 {1=negative}
end;
{subtitle 'ISSIGNIFICANDZERO',page}
function ISSIGNIFICANDZERO(var{} N:number; var{} gvars:gvarstype):boolean;
{Returns True if all significand bits are zero.}
{Number of significand bits checked is the current format's precision}
var I: 1..mant←bits←p1;
OK←SO←FAR: boolean;
begin
ok←so←far:=true; i:=1;
with n,gvars do begin
while (i<=mant←prec) and ok←so←far do begin
ok←so←far:= ok←so←far and (mant[i]=0); i:=i+1 end;
issignificandzero:=ok←so←far and (guard=0) and (round=0) and (sticky=0)
end
end;
{subtitle 'IS ZEROS,INFINITY',page}
function ISZERO(var{} N:number; var{} gvars:gvarstype):boolean;
{See if N zero; may be + or - or unnormal}
begin
iszero := issignificandzero(n,gvars) and (n.expon <> gvars.max←exp+1)
{not a NaN or infinity }
end;
function ISNORMALZERO(var{} N:number; var{} gvars:gvarstype):boolean;
{See if N is normal zero; may be positive or negative}
begin
isnormalzero := issignificandzero(n,gvars) and (n.expon=gvars.min←exp)
end;
function ISINFINITY(var{} N:number; var{} gvars:gvarstype):boolean;
{See if op is infinity, ignore sign}
begin
isinfinity := (n.expon=gvars.max←exp+1) and issignificandzero(n,gvars)
end;
{subtitle 'IS NAN,FINITE',page}
function ISNAN(var{} N:number; var{} gvars:gvarstype):boolean;
{See if op is a NaN}
begin
isnan := (n.expon=gvars.max←exp+1) and (not issignificandzero(n,gvars))
end;
function ISTRAPPINGNAN(var{} N:number; var{} gvars:gvarstype):boolean;
{Return True if op is a trapping NaN}
{This routine is implementation dependent!}
{Criteria used here is that most significant explicit mantissa bit}
{is 1 if trapping}
begin
if (gvars.format=single) or (gvars.format=double)
then istrappingnan := isnan(n,gvars) and (n.mant[2]=1) {hidden leading}
else istrappingnan := isnan(n,gvars) and (n.mant[1]=1) {explicit leading}
end;
function ISFINITE(var{} N:number; var{} gvars:gvarstype):boolean;
begin
isfinite := not (isinfinity(n,gvars) or isnan(n,gvars))
end;
{subtitle 'issame',page}
function issame(var{} N1,N2:number; var{} gvars:gvarstype):boolean;
var I:integer;
begin {slow}
issame:=true;
if (n1.sign<>n2.sign) or (n1.expon<>n2.expon) then issame:=false
else for i:=1 to gvars.mant←prec do
if n1.mant[i]<>n2.mant[i] then issame:=false
end;
{subtitle 'NORMALIZED QUERYS',page}
function ISUNNORMALIZED(var{} N:number;var{} gvars:gvarstype):boolean;
{Return true if N is unnormalized, includes denormalized}
{Returns false for normal zero, true for unnormal zero}
begin
isunnormalized := (n.mant[1]=0) and not isnormalzero(n,gvars)
end;
function ISDENORMALIZED(var{} N:number; var{} gvars:gvarstype):boolean;
{Return True if N is denormalized}
{Zero is not denormalized.}
begin
isdenormalized := isunnormalized(n,gvars) and (n.expon=gvars.min←exp)
end;
function ISNORMALIZED(var{} N:number; var{} gvars:gvarstype):boolean;
{Return True if N is normalized.}
{Returns false for zero.}
begin
isnormalized := (N.mant[1]=1)
end;
{subtitle 'FLAG SETTING',page}
procedure SET←DIVBYZERO(var INDICS:indicstype);
begin
indics.divbyzero←indic := on
end;
procedure SET←INVALID(var INDICS:indicstype);
begin
indics.invalid←indic := on
end;
procedure SET←OVERFLOW(var INDICS:indicstype);
begin
indics.overflow←indic := on
end;
procedure SET←UNDERFLOW(var INDICS:indicstype);
begin
indics.underflow←indic := on
end;
procedure SET←INEXACT(var INDICS:indicstype);
begin
indics.inexact←indic := on
end;
procedure UPDATE←FLAGS(var INDICS:indicstype);
begin
with indics do begin
if invalid←indic =on then begin
invalid←flag :=on;
inexact←indic :=off {invalid masks inexact}
end;
if divbyzero←indic=on then divbyzero←flag:=on;
if overflow←indic =on then overflow←flag :=on;
if underflow←indic=on then underflow←flag:=on;
if inexact←indic =on then inexact←flag :=on
end
end;
{subtitle 'NaN SELECTION',page}
procedure GETTRAPPINGNAN(var result: number; var{} gvars:gvarstype);
{Implementation Dependent!}
{Returns a trapping NaN. Definition of trapping used here is that }
{Most significant explicit mantissa bit is 1, all other mant bits set to zero}
var I: 1..mant←bits;
begin
result.sign := 0;
result.expon := gvars.max←exp+1;
for i:=1 to gvars.mant←prec do result.mant[i] := 0;
if (gvars.format=single) or (gvars.format=double)
then result.mant[2] := 1 {most sig explicit mant bit}
else result.mant[1] := 1 {most sig explicit mant bit}
end;
procedure GETNONTRAPPINGNAN(var result: number; var{} gvars:gvarstype);
{Implementation Dependent!}
{Criteria used here is that most significant explicit mantissa bit is }
{zero; here the following bit is set to one to distinguish from infinity}
var I: 1..mant←bits;
begin
result.sign := 0;
result.expon := gvars.max←exp+1;
for i:=1 to gvars.mant←prec do result.mant[i] := 0;
if (gvars.format=single) or (gvars.format=double)
then result.mant[3] := 1 {hidden msb}
else result.mant[2] := 1 {explicit msb}
end;
procedure GETNAN(var result: number; var{} MODES:MODEStype; var{} gvars:gvarstype);
{Return Trapping NaN if invalid trap enabled, else Nontrapping}
begin
if MODES.invalid←trap=enabled then gettrappingnan (result, gvars)
else getnontrappingnan (result, gvars)
end;
procedure SELECTNAN(var result: number; var{} op1,op2:number);
{Both op's are NaN's, pick one}
{This routine is implementation dependent!}
begin
result := op1
end;
{subtitle 'PLUSINF',page}
procedure PLUSINF(var result: number; var{} gvars:gvarstype);
{Return positive infinity}
var I: 1..mant←bits;
begin
result.sign:=0;
result.expon:=gvars.max←exp+1;
for i:=1 to gvars.mant←prec do result.mant[i]:=0
end;
{subtitle 'FLMO',page}
function FLMO(var{} OP:mant←array; var{} GVARS:gvarstype):integer;
{Find left-most one, far left is 0, far right is mant←prec-1, none is -1}
{ guard is mant←prec, round is mant←prec+1, sticky is mant←prec+2}
var i: 1..mant←bits;
begin
flmo:=-1;
with gvars do begin
if sticky=1 then flmo:=mant←prec+2;
if round =1 then flmo:=mant←prec+1;
if guard =1 then flmo:=mant←prec;
for i:=mant←prec downto 1 do if op[i]=1 then flmo:=i-1
end
end;
{subtitle 'OPERAND CASES',page}
function ONEOPERANDCASE(var{} OP: number;
var{} gvars:gvarstype):oneoperandtype;
{Unreadable without Coonan's Implementation Guide}
begin
if isnormalzero(op,gvars) then oneoperandcase:=pmzero else
if isinfinity(op,gvars) then oneoperandcase:=pminf else
if isnan(op,gvars) then oneoperandcase:=nan else
oneoperandcase:=W
end;
function TWOOPERANDCASE(var{} OP1,OP2: number;
var{} gvars: gvarstype):twooperandtype;
{Unreadable without Coonan's Implementation Guide}
{type row = array[oneoperandtype] of twooperandtype;
tabletype = array[oneoperandtype] of row;
const TABLE = tabletype[row[a, b, c, Y],
row[d, e, f, Y],
row[g, h, i, Y],
row[X, X, X, M]]; }
begin
{ twooperandcase:=table[oneoperandcase(op1,gvars)][oneoperandcase(op2,gvars)] }
case oneoperandcase (op1,gvars) of
pmzero: case oneoperandcase (op2, gvars) of
pmzero: twooperandcase := a;
W: twooperandcase := b;
pminf: twooperandcase := c;
NaN: twooperandcase := Y;
end;
W: case oneoperandcase (op2, gvars) of
pmzero: twooperandcase := d;
W: twooperandcase := e;
pminf: twooperandcase := f;
NaN: twooperandcase := Y;
end;
pminf: case oneoperandcase (op2, gvars) of
pmzero: twooperandcase := g;
W: twooperandcase := h;
pminf: twooperandcase := i;
NaN: twooperandcase := Y;
end;
NaN: case oneoperandcase (op2, gvars) of
pmzero: twooperandcase := X;
W: twooperandcase := X;
pminf: twooperandcase := X;
NaN: twooperandcase := M;
end;
end;
end;
{subtitle 'SHFTL',page}
procedure SHFTL(var N:number; D:integer; var gvars:gvarstype);
{shift significand left, no exponent change, use G,R,S,carry}
var I: 1..mant←bits←m1;
CNTR: integer;
begin
with N,gvars do begin
if d>mant←prec+3 then d:=mant←prec+3; {allows shift sticky to carry}
for cntr:=1 to d do begin
if carry=1 then halt(1); {Shouldn't happen.}
carry := mant[1];
for i:=1 to mant←prec-1 do
mant[i] := mant[i+1];
mant[mant←prec] := guard;
guard := round;
round := sticky
{sticky := sticky}
end
end
end;
{subtitle 'SHFTR',page}
procedure SHFTR(var N:number; D:integer; var gvars:gvarstype);
{shift significand right, D places, no exp change, use G,R,S,carry}
var I: 2..mant←bits;
CNTR: integer;
begin
with N,gvars do begin
if d>mant←prec+3 then d:=mant←prec+3; {allows shift carry to sticky}
for cntr:=1 to d do begin
if sticky=0 then sticky:=round;
round := guard;
guard := mant[mant←prec];
for i:=mant←prec downto 2 do
mant[i] := mant[i-1];
mant[1] := carry;
carry := 0
end
end
end;
{subtitle 'EXAMINE', page}
function EXAMINE(var N:number; var{} MODES:MODEStype;
var indics:indicstype; var gvars:gvarstype):boolean;
{If N is trapping NaN, set Invalid
If normalizing mode, normalize denormalized operand.}
var SHIFTDIST: integer;
begin
with MODES, indics, gvars do
if istrappingnan(n,gvars)
then begin set←invalid(indics); examine:=false end
else begin
examine:=true;
if (under←mode=normalizing) and isdenormalized(n,gvars)
then with n do begin
shiftdist := flmo(mant,gvars);
shftl(n, shiftdist, gvars);
expon := expon-shiftdist
end
end
end;
{subtitle 'ROUNDNUM',page}
procedure ROUNDNUM(var N:number; var{} MODES:MODEStype;
var indics:indicstype; var gvars:gvarstype); {uses G,R,S}
procedure increment(var m:mant←array);
var i:1..mant←bits; sum:0..2; c:bit;
begin
sum:=0; c:=1;
for i:=gvars.mant←prec downto 1 do
begin
sum:=m[i]+c;
m[i]:=sum mod 2;
c:=sum div 2
end;
if gvars.carry=1 then halt(2);
gvars.carry:=c {what if this carry's out???}
end;
begin
with N,MODES,indics,gvars do
if (guard=1) or (round=1) or (sticky=1)
then begin
set←inexact(indics);
case round←mode of
rp: if (sign=0)
then begin
increment(mant);
if carry=1
then begin shftr(n,1,gvars); expon:=expon+1 end
end;
rm: if (sign=1)
then begin
increment(mant);
if carry=1
then begin shftr(n,1,gvars); expon:=expon+1 end
end;
rz: {nada};
rn: if (guard=1)
and ( ((round=1) or (sticky=1))
or ((round=0) and (sticky=0) and (mant[mant←prec]=1)) )
then begin
increment(mant);
if carry=1
then begin shftr(n,1,gvars); expon:=expon+1 end
end;
end
end
end;
{subtitle 'CHECK←UNDER←AND←ROUND',page}
procedure CHECK←UNDER←AND←ROUND(var N:number; var{} MODES:MODEStype;
var indics:indicstype; var gvars:gvarstype);
{check underflow and round}
var I,K: integer;
UNROUNDEDN: number;
OLDGVARS: gvarstype;
begin
with n,MODES,indics,gvars do begin
oldgvars:=gvars;
unroundedn:=n;
if not check←underflow←before←rounding
then roundnum(n,MODES,indics,gvars);
if expon<min←exp {BUG: what if unnormalized prod indisting from}
then if underflow←trap=enabled {normal zero?}
then begin
set←underflow(indics);
case format of
single: expon:=expon+192-bias; {Kludge, pack will add}
double: expon:=expon+1536-bias; {in the bias}
extended: begin
k:=1;
for i:=1 to mant←prec-2 do k:=k*2;
expon:=expon+k-bias
end
end
end
else begin
set←underflow(indics);
if not check←underflow←before←rounding
then begin
n:=unroundedn; {avoid double rounding}
gvars:=oldgvars {restore possible flags gend by rounding}
end;
shftr(n,min←exp-expon,gvars); expon:=min←exp;
if not check←underflow←before←rounding
then roundnum(n,MODES,indics,gvars) {must re-round}
end;
if check←underflow←before←rounding then roundnum(n,MODES,indics,gvars)
end
end;
{subtitle 'CHECK INVALID AND OVERFLOW',page}
procedure CHECK←INV←AND←OV(var N:number; var{} MODES:MODEStype;
var indics:indicstype; var gvars:gvarstype);
var S: bit;
I: 1..mant←bits;
K,J: integer;
begin with n,MODES,indics,gvars do
if isunnormalized(N,gvars) and (not isdenormalized(n,gvars))
and ((format=single) or (format=double))
then begin set←invalid(indics); getnan(n, MODES,gvars) end
else with n do begin
if expon>max←exp
then case overflow←trap of
enabled: begin
set←overflow(indics);
case format of
single: expon:=expon-192-bias; {Kludge, }
double: expon:=expon-1536-bias; {pack wil}
extended: begin {add in }
k:=1; {the bias}
for j:=1 to mant←prec-2 do
k:=k*2;
expon:=expon-3*k-bias
end
end
end;
disabled:begin
set←overflow(indics);
set←inexact(indics);
if ((round←mode=rm) and (sign=0))
or ((round←mode=rz) and (sign=0))
or ((round←mode=rp) and (sign=1))
or ((round←mode=rz) and (sign=1))
then begin
if isnormalized(n,gvars)
then for i:=1 to mant←prec do mant[i]:=1;
expon:=max←exp
end
else begin
s:=sign; plusinf(n, gvars); sign:=s
end
end
end
end
end;
{subtitle 'ADD UTILITIES',page}
procedure addsignificands(var result:mant←array; var{} op1,op2:mant←array;
var gvars:gvarstype);
var i,sum:integer;
begin
with gvars do
for i:=mant←prec downto 1 do begin
sum:=op1[i]+op2[i]+carry;
result[i]:= sum mod 2;
carry:=sum div 2
end
end;
procedure ADDOPERANDS(var RESULT:number; var{} OP1,OP2:number;
var gvars:gvarstype);
{Used by ADD, assumes that operands are aligned, GRS set by alignment}
var C: bit;
procedure compl(var n:mant←array);
var i:integer;
begin
with gvars do begin
for i:=mant←prec downto 1 do n[i]:=1-n[i];
guard:=1-guard; round:=1-round; sticky:=1-sticky
end
end;
procedure addtogrs; {add carry to g,r,s}
var sum:0..2;
begin
with gvars do begin
sum:=carry+sticky; sticky:=sum mod 2; carry:=sum div 2;
sum:=carry+round; round :=sum mod 2; carry:=sum div 2;
sum:=carry+guard; guard :=sum mod 2; carry:=sum div 2
end
end;
begin
with gvars do begin
if isnormalzero(op1,gvars) then op1.expon:=op2.expon;
if isnormalzero(op2,gvars) then op2.expon:=op1.expon;
if op1.expon<>op2.expon then halt(3); {Ref: Hwang, COMPUTER ARITHMETIC}
result.expon:=op1.expon; { Wiley&Sons, 1979, p. 73 }
{ Extended by adding extra msb }
carry:=0;
if op1.sign <> op2.sign then compl(op2.mant);
addtogrs; addsignificands(result.mant, op1.mant, op2.mant, gvars);
c :=(carry+xor(op1.sign,op2.sign)) div 2;
carry:=(carry+xor(op1.sign,op2.sign)) mod 2;
if c=1
then begin
carry:=1;
addtogrs; addsignificands(result.mant, op1.mant, op2.mant, gvars);
c :=(carry+xor(op1.sign,op2.sign)) div 2;
carry:=(carry+xor(op1.sign,op2.sign)) mod 2
end;
if (c=0) and (op1.sign<>op2.sign)
then begin compl(result.mant); carry:=1-carry end;
if c=1 then result.sign:=op1.sign else result.sign:=op2.sign
end
end;
{subtitle 'MULTSIGNIFICANDS',page}
procedure MULTSIGNIFICANDS(var RESULT:number; var{} OP1,OP2:number;
var gvars:gvarstype);
var I: 1..mant←bits;
begin
with result,gvars do begin
for i:=1 to mant←prec do mant[i]:=0; {clean it up}
for i:=mant←prec downto 1 do begin
shftr(result,1,gvars);
if op2.mant[i]=1 then addsignificands(mant, mant, op1.mant, gvars)
end
end
end;
{subtitle 'DIVIDESIGNIFICANDS',page}
procedure DIVIDESIGNIFICANDS(var RESULT:number; var{} OP1,OP2:number;
var gvars:gvarstype);
var I: 1..mant←bits←p1;
J: 1..mant←bits←p2;
DONE: boolean;
DIF: 0..3;
BORROW:bit;
G,R: bit;
DOIT: boolean;
begin
with gvars do begin
for i:=1 to mant←prec do result.mant[i]:=0; {clean up}
for j:=1 to mant←prec+2 do begin {compute result[j]gr and update dividend}
done:=false; i:=1; doit:=true;
if j=(mant←prec+2) then r:=1 else
if j=(mant←prec+1) then g:=1 else
result.mant[j]:=1;
while (i<=mant←prec) and not done do begin {see which is bigger}
if (carry=1) or (op1.mant[i]<>op2.mant[i])
then begin
done:=true;
if (carry=0) and (op1.mant[i]<op2.mant[i])
then begin
if j=(mant←prec+2) then r:=0 else
if j=(mant←prec+1) then g:=0 else
result.mant[j]:=0;
doit:=false
end
end;
i:=i+1
end;
if doit then begin {subtract}
borrow:=1;
for i:=mant←prec downto 1 do begin
dif:=op1.mant[i]+(1-op2.mant[i])+borrow;
op1.mant[i]:=dif mod 2;
borrow:=dif div 2
end;
carry:=(carry+1+borrow) mod 2
end;
shftl(op1,1,gvars)
end;
{guard:=op1.mant[1]; round:=op1.mant[2]; sticky:=op1.mant[3];}
guard:=g; round:=r; sticky:=carry; carry:=0;
for i:=1 to mant←prec do if sticky=0 then sticky:=op1.mant[i]
end
end;
{subtitle 'PACK',page}
procedure PACK(var result: pervert; var{} N:number; var gvars:gvarstype);
var temp1: pervert;
tempE: pervert;
J: 1..mant←bits;
start: 1..2;
begin
with gvars do begin
if (((format=single) or (format=double)) and (isdenormalized(n,gvars)))
or isnormalzero(n,gvars)
then tempE.i := 0
else tempE.i := n.expon+bias;
with temp1 do for j:=1 to expbits do
b[expbits+mant←prec-j]:=tempE.b[expbits-j+1];
temp1.b[mant←prec+expbits] := n.sign;
if format=extended then start:=1 else start:=2;
with temp1 do
for j:=start to mant←prec do
b[1+mant←prec-j]:=n.mant[j];
result:=temp1
end
end;
procedure PACKS(var result: SHORTREAL; var{} N:number; var gvars:gvarstype);
var pack←result: pervert;
begin
pack (pack←result, n, gvars);
result := pack←result.r;
end;
procedure PACKD(var result: LONGREAL; var{} N:number; var gvars:gvarstype);
var pack←result: pervert;
begin
pack (pack←result, n, gvars);
result := pack←result.l
end;
procedure PACKE(var result: veryLONGREAL; var{} N:number; var gvars:gvarstype);
var pack←result: pervert;
begin
pack (pack←result, n, gvars);
result := pack←result.vl
end;
{subtitle 'UNPACK',page}
procedure UNPACK(var result: number; var{} T1:pervert; var gvars:gvarstype);
var TE: pervert;
J: 1..mant←bits;
RES: number;
START: integer;
begin
with gvars,res do begin
te.i := 0;
with te do for j:=1 to expbits do
b[expbits-j+1]:=t1.b[expbits+mant←prec-j];
expon := te.i - bias;
if format=extended then start:=1 else start:=2;
for j:=start to mant←prec do
mant[j] := t1.b[1+mant←prec-j];
if format<>extended then
if expon >= min←exp {not denorm}
then mant[1]:=1
else begin mant[1]:=0; expon:=min←exp end;
if format<>extended then
if expon = max←exp+1 {infinity}
then mant[1]:=0;
sign := t1.b[expbits+mant←prec];
result:=res
end
end;
procedure UNPACKS(var result: number; var{} N:SHORTREAL; var gvars:gvarstype);
var t:pervert;
begin
t.r := n;
unpack(result, t,gvars)
end;
procedure UNPACKD(var result: number; var{} N:LONGREAL; var gvars:gvarstype);
var T: pervert;
begin
t.l := n;
unpack(result, t,gvars)
end;
procedure UNPACKE(var result: number; var{} N:veryLONGREAL; var gvars:gvarstype);
var T: pervert;
begin
t.vl := n;
unpack(result, t,gvars)
end;
{subtitle 'ADD',page}
procedure ADD(var RESULT:number; OP1,OP2:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
var OP1OK,OP2OK,ONENORMALIZED: boolean;
SHIFTDIST: integer;
TEMP: number;
begin
op1ok:=examine(op1,MODES,indics,gvars);
op2ok:=examine(op2,MODES,indics,gvars);
if op1ok and op2ok then with MODES,indics,gvars do
case twooperandcase(op1,op2,gvars) of
a: if ((round←mode<>rm) and not ((op1.sign=1) and (op2.sign=1)))
or ((op1.sign=0) and (op2.sign=0))
then pluszero(result, gvars)
else minuszero(result, gvars);
c,f: result := op2; {op2 is inf & op1 is not inf or nan}
g,h: result := op1; {op1 is inf & op2 is not inf or nan}
b,d,e: begin
{1} if (not isnormalzero(op1,gvars)) and
(not isnormalzero(op2,gvars)) and
(op1.expon<>op2.expon)
then begin
if op1.expon<op2.expon
then begin
temp:=op1; op1:=op2; op2:=temp
end;
shftr(op2,op1.expon-op2.expon,gvars);
op2.expon:=op1.expon
end;
onenormalized := isnormalized(op1,gvars) or
isnormalized(op2,gvars);
addoperands(result, op1, op2, gvars);
{2} if carry=1 then
begin
shftr(result,1,gvars);
result.expon:=result.expon+1
end;
{3} if issignificandzero(result,gvars)
{a} then begin
if round←mode=rm
then result.sign:=1 else result.sign:=0;
if onenormalized then result.expon:=gvars.min←exp
end
{b} else if onenormalized then begin
shiftdist:=flmo(result.mant,gvars);
shftl(result, shiftdist, gvars);
result.expon:=result.expon-shiftdist
end;
{4} CHECK←UNDER←AND←ROUND(result,MODES,indics,gvars);
check←inv←and←ov(result, MODES,indics,gvars)
end;
i: begin {both infinity}
if (infinity←mode=affine) and (op1.sign=op2.sign)
then result := op1
else begin
set←invalid(indics);
getnan(result, MODES,gvars)
end
end;
X: result := op1; {op1 is NaN, op2 is non-NaN}
Y: result := op2; {op2 is NaN, op1 is non-NaN}
M: selectnan (result, op1,op2) {Both op's are NaN}
end
else getnan(result, MODES,gvars)
end;
{subtitle 'SUBTRACT',page}
procedure SUBTRACT(var RESULT:number; OP1,OP2:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
begin
if not isnan(op2,gvars) then op2.sign := 1-op2.sign;
ADD(result, op1,op2, MODES,indics,gvars)
end;
{subtitle 'MULTIPLY',page}
procedure MULTIPLY(var RESULT:number; OP1,OP2:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
var OP1OK,OP2OK: boolean;
begin
op1ok:=examine(op1, MODES,indics,gvars);
op2ok:=examine(op2, MODES,indics,gvars);
if op1ok and op2ok then with MODES,indics,gvars do
case twooperandcase(op1,op2,gvars) of
a,b,d: begin
zero(result, gvars); result.sign:=xor(op1.sign,op2.sign)
end;
c,g: begin set←invalid(indics); getnan(result, MODES,gvars) end;
e: begin
{1} result.sign:=xor(op1.sign,op2.sign);
result.expon:=op1.expon+op2.expon;
multsignificands(result,op1,op2, gvars);
{2} if carry=1
then begin
shftr(result,1,gvars);
result.expon:=result.expon+1
end;
{3} CHECK←UNDER←AND←ROUND(result,MODES,indics,gvars);
check←inv←and←ov(result, MODES,indics,gvars)
end;
f,h,i: if (iszero(op1,gvars) and not isnormalzero(op1,gvars)) or
(iszero(op2,gvars) and not isnormalzero(op2,gvars))
then begin set←invalid(indics); getnan(result, MODES,gvars) end
else begin
plusinf(result, gvars);
result.sign:=xor(op1.sign,op2.sign)
end;
X: result:=op1;
Y: result:=op2;
M: selectnan (result, op1,op2)
end
else getnan (result, MODES,gvars)
end;
{subtitle 'DIVIDE',page}
procedure DIVIDE(var RESULT:number; OP1,OP2:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
var OP1OK,OP2OK: boolean;
begin
op1ok:=examine(op1, MODES,indics,gvars);
op2ok:=examine(op2, MODES,indics,gvars);
if op1ok and op2ok then with MODES,indics,gvars do
case twooperandcase(op1,op2,gvars) of
a,i: begin set←invalid(indics); getnan (result, MODES,gvars) end;
b: begin
if iszero(op2,gvars) and not isnormalzero(op2,gvars)
then begin
set←invalid(indics);
getnan(result, MODES,gvars)
end
else begin
zero(result, gvars);
result.sign := xor(op1.sign, op2.sign)
end
end;
c,f: begin
zero(result, gvars);
result.sign := xor(op1.sign, op2.sign)
end;
d: if iszero(op1,gvars) and not isnormalzero(op1,gvars)
then begin set←invalid(indics); getnan(result, MODES,gvars) end
else begin
set←divbyzero(indics);
plusinf (result, gvars);
result.sign:=xor(op1.sign, op2.sign)
end;
e: if isunnormalized(op2,gvars)
then begin set←invalid(indics); getnan (result, MODES,gvars) end
else begin
{1} result.sign:=xor(op1.sign, op2.sign);
result.expon:=op1.expon-op2.expon;
dividesignificands(result,op1,op2,gvars);
{2} if result.mant[1]=0
then begin
shftl(result,1,gvars);
result.expon:=result.expon-1
end;
{3} CHECK←UNDER←AND←ROUND(result,MODES,indics,gvars);
check←inv←and←ov(result, MODES,indics,gvars)
end;
g,h: begin
plusinf (result, gvars); result.sign:=xor(op1.sign,op2.sign)
end;
X: result:=op1;
Y: result:=op2;
M: selectnan (result, op1,op2)
end
else getnan(result, MODES,gvars)
end;
{subtitle 'REMAINDER',page}
procedure REMAINDER(var RESULT:number; OP1,OP2:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
var OP1OK,OP2OK: boolean;
{bugs - incomplete}
{If remainder is zero, its sigh is that of the dividend}
begin
op1ok:=examine(op1,MODES,indics,gvars);
op2ok:=examine(op2,MODES,indics,gvars);
if op1ok and op2ok then with MODES,indics,gvars do
case twooperandcase(op1,op2,gvars) of
a,d,g,h,i: begin set←invalid(indics); getnan (result, MODES,gvars) end;
b,c: if isunnormalized(op2,gvars)
then begin
set←invalid(indics);
getnan (result, MODES,gvars)
end
else result:=op1;
e: {writeln('Part e not yet implemented')} halt(4) ;
f: result:=op2;
X: result:=op1;
Y: result:=op2;
M: selectnan(result, op1,op2)
end
else getnan (result, MODES,gvars)
end;
{subtitle 'SQRTT',page}
procedure SQRTT(var RESULT:number; OP:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
{Note: can't call it SQRT in a segment, conflicts with pascal intrinsic}
begin
if examine(op, MODES,indics,gvars) then with MODES,indics,gvars do
case oneoperandcase(op, gvars) of
pmzero: result:=op; {bugs - incomplete}
pminf: if (op.sign=1) or (infinity←mode=projective)
then begin
set←invalid(indics);
getnan (result, MODES,gvars)
end
else result:=op;
W: {writeln('Not yet')} halt(5);
NaN: result:=op
end
else getnan (result, MODES,gvars)
end;
{subtitle 'CONVERT',page}
procedure CONVERT(var RESULT:number; RESTYPE:formattype;
OP: number; OPTYPE: formattype;
var{} MODES:MODEStype; var indics:indicstype; var gvars:gvarstype);
begin
{writeln('CONVERT not yet implemented')} halt(6) {bugs - incomplete}
end;
{subtitle 'INTEGERIZE',page}
procedure INTEGERIZE(var RESULT:number; OP:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
var SHIFTDIST: integer;
begin
if examine(op, MODES,indics,gvars) then with MODES,indics,gvars do
case oneoperandcase(op, gvars) of
pmzero: result:=op;
pminf: result:=op;
W: with op do
if expon>=mant←prec-1 then result:=op
else begin
{1} shftr(op,mant←prec-1-expon,gvars);
expon:=mant←prec-1;
{2} result:=op; roundnum(result,MODES,indics,gvars);
guard:=0; round:=0; sticky:=0;
{3} if issignificandzero(result,gvars)
then result.expon:=min←exp
else begin
shiftdist:=flmo(result.mant,gvars);
shftl(result, shiftdist, gvars);
result.expon:=result.expon-shiftdist
end
end;
NaN: result:=op
end
else getnan(result, MODES,gvars)
end;
{subtitle 'BINDEC',page}
procedure BINDEC(var RESULT:string; OP:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
begin
{writeln('BINDEC not yet implemented')} halt(7) {bugs - incomplete}
end;
{subtitle 'DECBIN',page}
procedure DECBIN(var RESULT:number; var{} OP:string;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
begin
{writeln('DECBIN not yet implemented')} halt(8) {bugs - incomplete}
end;
{subtitle 'COMPARE',page}
procedure COMPARE(var RESULT:cc; OP1,OP2:number;
var{} MODES:MODEStype; var indics:indicstype;
var gvars:gvarstype);
var i:integer;
begin
with MODES do begin
{Unordered cases}
if (isnan(op1,gvars) or isnan(op2,gvars))
or ( (infinity←mode=projective)
and ( (isinfinity(op2,gvars) and isfinite(op1,gvars))
or (isinfinity(op1,gvars) and isfinite(op2,gvars)) ) )
then RESULT:=UN else
{Special (sign independent) Equal cases}
if (infinity←mode=projective) and (isinfinity(op1,gvars)) and
(isinfinity(op2,gvars)) then RESULT:=EQ else
if iszero(op1,gvars) and iszero(op2,gvars) then RESULT:=EQ else
{Equal case}
if (issame(op1,op2,gvars)) then RESULT:=EQ else
{Bit compare necessary}
if op1.sign<>op2.sign
then if op1.sign=0 then RESULT:=GT else RESULT:=LT else
if op1.expon<>op2.expon
then begin
if ((op1.expon>op2.expon) and (op1.sign=0))
or ((op1.expon<op2.expon) and (op1.sign=1))
then RESULT:=GT else RESULT:=LT
end else
begin {mantissa check necessary}
i:=1;
while (i<=gvars.mant←prec) and (op1.mant[i]=op2.mant[i]) do i:=i+1;
if i>gvars.mant←prec then halt(9) {were equal, tested above}
else if ((op1.mant[i]=1) and (op1.sign=0))
or ((op1.mant[i]=0) and (op1.sign=1))
then RESULT:=GT else RESULT:=LT
end
end
end;
{subtitle 'RESETIG',page}
procedure RESETIG(var GVARS:gvarstype; var INDICS:indicstype);
begin
with gvars do begin
guard:=0; round:=0; sticky:=0; carry:=0
end;
with indics do begin
invalid←indic:=off; divbyzero←indic:=off; overflow←indic:=off;
underflow←indic:=off; inexact←indic:=off
end
end;
{subtitle 'SET PRECISION UTILITIES',page}
procedure SETSINGLE(var GVARS:gvarstype; var indics:indicstype);
begin
with gvars do begin
format := single;
expbits := single←exp←bits;
mant←prec := single←mant←bits;
min←exp := single←min←exp;
max←exp := single←max←exp;
bias := single←bias
end
end;
procedure SETDOUBLE(var GVARS:gvarstype; var indics:indicstype);
begin
with gvars do begin
format := double;
expbits := double←exp←bits;
mant←prec := double←mant←bits;
min←exp := double←min←exp;
max←exp := double←max←exp;
bias := double←bias
end
end;
procedure SETEXTENDED(var GVARS:gvarstype; var indics:indicstype);
begin
with gvars do begin
format := extended;
expbits := extended←exp←bits;
mant←prec := extended←mant←bits;
min←exp := extended←min←exp;
max←exp := extended←max←exp;
bias := extended←bias
end
end;
{subtitle 'ADDS',page}
{visible on}
procedure ADDS(var result: SHORTREAL; var{} N1,N2:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n1←unpacked, n1, gvars);
unpacks (n2←unpacked, n2, gvars);
add(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packs(result, res,gvars); update←flags(indics)
end;
procedure ADDD(var result: LONGREAL; var{} N1,N2:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n1←unpacked, n1, gvars);
unpackd (n2←unpacked, n2, gvars);
add(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packd(result, res,gvars); update←flags(indics)
end;
procedure ADDE(var result: veryLONGREAL; var{} N1,N2:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n1←unpacked, n1, gvars);
unpacke (n2←unpacked, n2, gvars);
add(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packe(result, res,gvars); update←flags(indics)
end;
{subtitle 'SUBS',page}
procedure SUBS(var result: SHORTREAL; var{} N1,N2:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n1←unpacked, n1, gvars);
unpacks (n2←unpacked, n2, gvars);
subtract(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packs (result, res,gvars); update←flags(indics)
end;
procedure SUBD(var result: LONGREAL; var{} N1,N2:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n1←unpacked, n1, gvars);
unpackd (n2←unpacked, n2, gvars);
subtract(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packd(result, res,gvars); update←flags(indics)
end;
procedure SUBE(var result: veryLONGREAL; var{} N1,N2:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n1←unpacked, n1, gvars);
unpacke (n2←unpacked, n2, gvars);
subtract(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packe (result, res,gvars); update←flags(indics)
end;
{subtitle 'MULS',page}
procedure MULS(var result: SHORTREAL; var{} N1,N2:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n1←unpacked, n1, gvars);
unpacks (n2←unpacked, n2, gvars);
MULTIPLY(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packs(result, res, gvars); update←flags(indics)
end;
procedure MULD(var result: LONGREAL; var{} N1,N2:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n1←unpacked, n1, gvars);
unpackd (n2←unpacked, n2, gvars);
MULTIPLY(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packd(result, res, gvars); update←flags(indics)
end;
procedure MULE(var result: veryLONGREAL; var{} N1,N2:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n1←unpacked, n1, gvars);
unpacke (n2←unpacked, n2, gvars);
MULTIPLY(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packe(result, res, gvars); update←flags(indics)
end;
{subtitle 'DIVS',page}
procedure DIVS(var result: SHORTREAL; var{} N1,N2:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n1←unpacked, n1, gvars);
unpacks (n2←unpacked, n2, gvars);
divide(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packs(result, res, gvars); update←flags(indics)
end;
procedure DIVD(var result: LONGREAL; var{} N1,N2:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n1←unpacked, n1, gvars);
unpackd (n2←unpacked, n2, gvars);
divide(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packd(result, res, gvars); update←flags(indics)
end;
procedure DIVE(var result: veryLONGREAL; var{} N1,N2:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n1←unpacked, n1, gvars);
unpacke (n2←unpacked, n2, gvars);
divide(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packe(result, res, gvars); update←flags(indics)
end;
{subtitle 'REMS',page}
procedure REMS(var result: SHORTREAL; var{} N1,N2:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n1←unpacked, n1, gvars);
unpacks (n2←unpacked, n2, gvars);
remainder(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packs(result, res, gvars); update←flags(indics)
end;
procedure REMD(var result: LONGREAL; var{} N1,N2:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n1←unpacked, n1, gvars);
unpackd (n2←unpacked, n2, gvars);
remainder(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packd(result, res, gvars); update←flags(indics)
end;
procedure REME(var result: veryLONGREAL; var{} N1,N2:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n1←unpacked, n2←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n1←unpacked, n1, gvars);
unpacke (n2←unpacked, n2, gvars);
remainder(RES, n1←unpacked, n2←unpacked, MODES, indics, gvars);
packe(result, res, gvars); update←flags(indics)
end;
{subtitle 'SQRTS',page}
procedure SQRTS(var result: SHORTREAL; var{} N:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n←unpacked, n, gvars);
sqrtt(RES, n←unpacked, MODES, indics, gvars);
packs(result, res, gvars); update←flags(indics)
end;
procedure SQRTD(var result: LONGREAL; var{} N:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n←unpacked, n, gvars);
sqrtt(RES, n←unpacked, MODES, indics, gvars);
packd(result, res, gvars); update←flags(indics)
end;
procedure SQRTE(var result: veryLONGREAL; var{} N:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n←unpacked, n, gvars);
sqrtt(RES, n←unpacked, MODES, indics, gvars);
packe(result, res, gvars); update←flags(indics)
end;
{subtitle 'CONSde',page}
procedure CONSD(var result: LONGREAL; var{} N:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype);
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n←unpacked, n, gvars);
convert(res, double, n←unpacked, single, MODES,indics,gvars);
packd(result, res, gvars); update←flags(indics)
end;
procedure CONSE(var result: veryLONGREAL; var{} N:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype);
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n←unpacked, n, gvars);
convert(res, extended, n←unpacked, single, MODES,indics,gvars);
packe(result, res, gvars); update←flags(indics)
end;
{subtitle 'CONDse',page}
procedure CONDS(var result: SHORTREAL; var{} N:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype);
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n←unpacked, n, gvars);
convert(res, single, n←unpacked, double, MODES,indics,gvars);
packs(result, res, gvars); update←flags(indics)
end;
procedure CONDE(var result: veryLONGREAL; var{} N:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype);
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n←unpacked, n, gvars);
convert(res, extended, n←unpacked, double, MODES,indics,gvars);
packe(result, res, gvars); update←flags(indics)
end;
{subtitle 'CONEsd',page}
procedure CONES(var result: SHORTREAL; var{} N:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype);
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n←unpacked, n, gvars);
convert(res, single, n←unpacked, extended, MODES,indics,gvars);
packs(result, res, gvars); update←flags(indics)
end;
procedure CONED(var result: LONGREAL; var{} N:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype);
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n←unpacked, n, gvars);
convert(res, double, n←unpacked, extended, MODES,indics,gvars);
packd(result, res, gvars); update←flags(indics)
end;
{subtitle 'INTS',page}
procedure INTS(var result: SHORTREAL; var{} N:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n←unpacked, n, gvars);
integerize(RES, n←unpacked, MODES, indics, gvars);
packs(result, res, gvars); update←flags(indics)
end;
procedure INTD(var result: LONGREAL; var{} N:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n←unpacked, n, gvars);
integerize(RES, n←unpacked, MODES, indics, gvars);
packd(result, res, gvars); update←flags(indics)
end;
procedure INTE(var result: veryLONGREAL; var{} N:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var RES: number;
GVARS: gvarstype;
n←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n←unpacked, n, gvars);
integerize(RES, n←unpacked, MODES, indics, gvars);
packe(result, res, gvars); update←flags(indics)
end;
{subtitle 'BINDEC',page}
procedure SBINDEC(var RES:string; var{} N:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype );
var GVARS: gvarstype;
n←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (n←unpacked, n, gvars);
bindec(res, n←unpacked, MODES, indics, gvars); update←flags(indics)
end;
procedure DBINDEC(var RES:string; var{} N:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var GVARS: gvarstype;
n←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (n←unpacked, n, gvars);
bindec(res, n←unpacked, MODES,indics,gvars); update←flags(indics)
end;
procedure EBINDEC(var RES:string; var{} N:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype );
var GVARS: gvarstype;
n←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (n←unpacked, n, gvars);
bindec(res, n←unpacked, MODES,indics,gvars); update←flags(indics)
end;
{subtitle 'DECBIN',page}
procedure SDECBIN(var result: SHORTREAL; var OP:string; var{} MODES:MODEStype;
var indics:indicstype);
var GVARS: gvarstype;
RES: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
decbin(res, op, MODES,indics,gvars);
packs(result, res, gvars); update←flags(indics)
end;
procedure DDECBIN(var result: LONGREAL; var OP:string; var{} MODES:MODEStype;
var indics:indicstype);
var GVARS: gvarstype;
RES: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
decbin(res, op, MODES,indics,gvars);
packd(result, res, gvars); update←flags(indics)
end;
procedure EDECBIN(var result: veryLONGREAL; var OP:string; var{} MODES:MODEStype; var indics:indicstype);
var GVARS: gvarstype;
RES: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
decbin(res, op, MODES,indics,gvars);
packe(result, res, gvars); update←flags(indics)
end;
{subtitle 'COMPARE',page}
function SCOMPARE(var OP1,OP2:SHORTREAL; var{} MODES:MODEStype;
var indics:indicstype ): CC;
var RES: cc;
GVARS: gvarstype;
op1←unpacked, op2←unpacked: number;
begin
setsingle(gvars, indics); resetig(gvars,indics);
unpacks (op1←unpacked, op1, gvars);
unpacks (op2←unpacked, op1, gvars);
compare(res, op1←unpacked, op2←unpacked, MODES,indics,gvars);
scompare:=res; update←flags(indics)
end;
function DCOMPARE(var OP1,OP2:LONGREAL; var{} MODES:MODEStype;
var indics:indicstype ): CC;
var RES: cc;
GVARS: gvarstype;
op1←unpacked, op2←unpacked: number;
begin
setdouble(gvars, indics); resetig(gvars,indics);
unpackd (op1←unpacked, op1, gvars);
unpackd (op2←unpacked, op1, gvars);
compare(res, op1←unpacked, op2←unpacked, MODES,indics,gvars);
dcompare:=res; update←flags(indics)
end;
function ECOMPARE(var OP1,OP2:veryLONGREAL; var{} MODES:MODEStype;
var indics:indicstype ): CC;
var RES: cc;
GVARS: gvarstype;
op1←unpacked, op2←unpacked: number;
begin
setextended(gvars, indics); resetig(gvars,indics);
unpacke (op1←unpacked, op1, gvars);
unpacke (op2←unpacked, op1, gvars);
compare(res, op1←unpacked, op2←unpacked, MODES,indics,gvars);
ecompare:=res; update←flags(indics)
end;
{main procedure}
begin
99: ;
end.