{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.