.CM  SCRIPT , Version - 1.1 , last edited by Manuela Rathmann
.ad 8
.bm 8
.fm 4
.bt $Copyright (c) 2000-2004 SAP AG$$Page %$
.tm 12
.hm 6
.hs 3
.TT 1 $SQL$Project Distributed Database System$VSP51$
.tt 2 $$$
.TT 3 $$Number-Arithmetic$1998-08-20$
***********************************************************
.nf
 
 .nf
 
 
    ========== licence begin  GPL
    Copyright (c) 2000-2004 SAP AG
 
    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.
 
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
 
    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    ========== licence end
 
.fo
 
 
.fo
.nf
.sp
MODULE  :  Number-Arithmetic
=========
.sp
Purpose :  Arithmetic for VDN-Numbers
.CM *-END-* purpose -------------------------------------
.sp
.cp 3
Define  :
 
        PROCEDURE
              s51abs (
                    VAR source     : tsp00_MoveObj;
                    spos           : tsp00_Int4;
                    slen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51add (
                    VAR left       : tsp00_MoveObj;
                    lpos           : tsp00_Int4;
                    llen           : integer;
                    VAR right      : tsp00_MoveObj;
                    rpos           : tsp00_Int4;
                    rlen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51div (
                    VAR left       : tsp00_MoveObj;
                    lpos           : tsp00_Int4;
                    llen           : integer;
                    VAR right      : tsp00_MoveObj;
                    rpos           : tsp00_Int4;
                    rlen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        FUNCTION
              s51floatlen (
                    VAR source   : tsp00_MoveObj;
                    spos         : tsp00_Int4;
                    slen         : integer) : integer;
 
        PROCEDURE
              s51intdiv (
                    VAR left       : tsp00_MoveObj;
                    lpos           : tsp00_Int4;
                    llen           : integer;
                    VAR right      : tsp00_MoveObj;
                    rpos           : tsp00_Int4;
                    rlen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51isint (
                    VAR source : tsp00_MoveObj;
                    spos       : tsp00_Int4;
                    slen       : integer;
                    VAR isint  : boolean;
                    VAR ret    : tsp00_NumError);
 
        PROCEDURE
              s51kroun (
                    VAR source     : tsp00_MoveObj;
                    spos           : tsp00_Int4;
                    slen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51mul (
                    VAR left       : tsp00_MoveObj;
                    lpos           : tsp00_Int4;
                    llen           : integer;
                    VAR right      : tsp00_MoveObj;
                    rpos           : tsp00_Int4;
                    rlen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51neg (
                    VAR source     : tsp00_MoveObj;
                    spos           : tsp00_Int4;
                    slen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51power (
                    VAR base       : tsp00_MoveObj;
                    basepos        : tsp00_Int4;
                    baselen        : integer;
                    basefrac       : integer;
                    VAR power      : tsp00_MoveObj;
                    ppos           : tsp00_Int4;
                    plen           : integer;
                    pfrac          : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51round (
                    VAR source     : tsp00_MoveObj;
                    spos           : tsp00_Int4;
                    slen           : integer;
                    round          : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51scale (
                    VAR vnumber : tsp00_Number;
                    scale       : integer;
                    VAR res     : tsp00_NumError);
 
        PROCEDURE
              s51sqrt (
                    VAR source     : tsp00_MoveObj;
                    spos           : tsp00_Int4;
                    slen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51sub (
                    VAR left       : tsp00_MoveObj;
                    lpos           : tsp00_Int4;
                    llen           : integer;
                    VAR right      : tsp00_MoveObj;
                    rpos           : tsp00_Int4;
                    rlen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR resbytelen : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s51trunc (
                    VAR source         : tsp00_MoveObj;
                    spos               : tsp00_Int4;
                    slen               : integer;
                    trunc              : integer;
                    VAR result         : tsp00_MoveObj;
                    respos             : tsp00_Int4;
                    reslen             : integer;
                    resfrac            : integer;
                    VAR resbytelen     : integer;
                    VAR ret            : tsp00_NumError);
 
.CM *-END-* define --------------------------------------
.sp;.cp 3
Use     :
 
        FROM
              Exponential-Functions : VSP52;
 
        PROCEDURE
              s52power (
                    VAR base       : tsp00_MoveObj;
                    basepos        : tsp00_Int4;
                    baselen        : integer;
                    basefrac       : integer;
                    VAR power      : tsp00_MoveObj;
                    ppos           : tsp00_Int4;
                    plen           : integer;
                    pfrac          : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR ret        : tsp00_NumError);
 
        PROCEDURE
              s52sqrt (
                    VAR source     : tsp00_MoveObj;
                    spos           : tsp00_Int4;
                    slen           : integer;
                    VAR result     : tsp00_MoveObj;
                    respos         : tsp00_Int4;
                    reslen         : integer;
                    resfrac        : integer;
                    VAR ret        : tsp00_NumError);
&       ifdef kdebug
 
      ------------------------------ 
 
        FROM
              Test_Procedures : VTA01;
 
        PROCEDURE
              t01line (debug : integer;
                    VAR msg : tsp00_Line);
 
        PROCEDURE
              t01int4 (debug : integer;
                    nam      : tsp00_Sname;
                    int      : tsp00_Int4);
 
        PROCEDURE
              t01sname (debug : integer;
                    nam : tsp00_Sname);
&       endif
 
.CM *-END-* use -----------------------------------------
.sp;.cp 3
Synonym :
 
.CM *-END-* synonym -------------------------------------
.sp;.cp 3
Author  : RudolfM / ThomasA
.sp
.cp 3
Created : 1983-11-18
.sp
.cp 3
.sp
.cp 3
Release :      Date : 1998-08-20
.sp
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Specification:
 
VSP51 requires the following type and constant definitions:
.sp;.nf
CONST
      float_frac = - 1;
.sp 2
Meaning of the parameters:
.sp
 left, right,
 source, result       : record or array that contains the SQL-DB
                        numbers (operands and result)
.sp
 lpos, rpos,
 spos, respos         : position of the operands or result
.sp
 llen, rlen, slen     : operand length in BYTES !!
.sp
 reslen               : result length in DIGITS !!
.sp
 resfrac              : number of result decimal places
.sp
 resbytelen           : result length in BYTES !! (output parameter)
.sp
 isint                : result of the integer test in S51ISINT
.sp
 trunc, round         : number of decimal places that are to remain after
                        truncating or rounding
.sp
 res                  : response concerning success or error situations
.sp;.fo
The arithmetic routines described below operate with a left and right
operand and a result.  The right operand is omitted for the unary
operations S51NEG, S51ABS, S51TRUNC, S51ROUND and S51SCALE and for the test
function S51ISINT.  Null values are accepted in the form of null_numbers
and send back a null_number ofr the desired length for all
arithmetic functions.  The fact that a null value occurs as a result
is signalled by the response "num_invalid".  If only the
exponent of a VDN number is 0, "num_overflow" is returned.
.sp 2
PROCEDURE S51ADD
.sp
Adds the left and right operands and supplies the result.
.sp
PROCEDURE S51SUB
.sp
Subtracts the right operand from the left and supplies the result.
.sp
PROCEDURE S51MUL
.sp
Multiplies the right operand by the left and supplies the result.
.sp
PROCEDURE S51DIV
.sp
Divides the left operand by the right and supplies the result.
.sp
PROCEDURE S51NEG
.sp
Reverses the sign of the operand and supplies the result.
.sp
PROCEDURE S51ABS
.sp
Makes the sign of the operand positive, i.e. forms the absolute value
of the operand and supplies the result.
.sp
PROCEDURE S51ISINT
.sp
Tests whether or not the specified operand is an integer.  All
values that can be represented by FIXED (18,0) are considered to be
integers.
The result is sent back in the parameter ISINT.
.sp
PROCEDURE S51TRUNC
.sp
Turns any number into a number with "trunc" decimal places.
If the number originally had fewer decimal places than are specified
by "trunc", it is filled up with zeros.
.br
This function operates on the VDN numbers that have been passed, i.e.
the statements on the size and representation of the number that were also
sent are only relevant for the obligatory push and pop operations
before and after truncation.
.br
True floating decimal places are also correctly truncated, i.e.
the position where the decimal point would be located is determined
and truncation is executed there, if appropriate.
.sp
PROCEDURE S51ROUND
.sp
Rounds the operand to the desired number of decimal places and
supplies the result.  If the round + 1. decimal places are >= 5,
rounding is executed; otherwise, the operand is truncated.
.br
The various data concerning input and output format are to ensure
that the result fits in the buffer provided, that the actual
rounding operation occurs independently and that it itself identifies
the form the number takes.
.br
Float numbers are also correctly rounded, i.e. only decimal places are
included in the rounding and the decimal position is identified on
the basis of the exponent and is most rarely in the place where the
decimal point is located in standardized mantisse/exponent
representations.
.sp
PROCEDURE S51KROUN
.sp
If the desired result is a float number, the source is rounded
to the desired number of digits specified in slen (sp51kernround).
If the desired result is a fixed number, the fraction of the
source is rounded to the desired number of digits specified
in sfrac (sp51round).
Rounding is executed if the trailing digit is >= 5.
.sp
PROCEDURE S51SCALE
.sp
This is the only procedure that expects a VDN number as a parameter.
Applies the specified scaling factor to the exponent of the
VDN number and supplies the result.
.CM *-END-* specification -------------------------------
.sp 2
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Description:
 
.CM *-END-* description ---------------------------------
.sp 2
***********************************************************
.sp
.cp 10
.nf
.oc _/1
Structure:
 
.CM *-END-* structure -----------------------------------
.sp 2
**********************************************************
.sp
.cp 10
.nf
.oc _/1
.CM -lll-
Code    :
 
 
CONST
      csp51_max_digits     =  38;
      csp51_numblen        =  81;
      csp51_intern_numblen =  40;
 
TYPE
      number = ARRAY [0..csp51_numblen] OF integer;
 
      tsp51operand = RECORD
            exp     : integer;
            abs_exp : integer;
            negative: boolean;
            dig_cnt : integer;
            hi      : integer;
            lo      : integer;
            digits  : number;
      END;
 
 
 
(*------------------------------*) 
 
PROCEDURE
      s51abs (
            VAR source     : tsp00_MoveObj;
            spos           : tsp00_Int4;
            slen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      op : tsp51operand;
 
BEGIN
ret         := num_ok;
op.exp      := ord (source [spos]);
op.negative := op.exp < csp_zero_exp_value;
IF  op.exp < csp_zero_exp_value
THEN
    op.abs_exp  := 64 - op.exp
ELSE
    IF  op.exp  = csp_zero_exp_value
    THEN
        op.abs_exp := 0
    ELSE
        op.abs_exp  := op.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
sp51unpack (source, spos, slen, 0, op, ret);
IF  op.negative AND (ret = num_ok)
THEN
    sp51compl  (op);
(*ENDIF*) 
sp51pack (op, result, respos, reslen, resfrac, resbytelen, ret)
END; (* s51abs *)
 
(*------------------------------*) 
 
PROCEDURE
      s51add (
            VAR left       : tsp00_MoveObj;
            lpos           : tsp00_Int4;
            llen           : integer;
            VAR right      : tsp00_MoveObj;
            rpos           : tsp00_Int4;
            rlen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      l, r : tsp51operand;
 
LABEL
      999;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51add      ', left, lpos, llen, right, rpos, rlen);
&endif
ret        := num_ok;
l.exp      := ord (left [lpos]);
r.exp      := ord (right [rpos]);
l.negative := l.exp < csp_zero_exp_value;
r.negative := r.exp < csp_zero_exp_value;
IF  l.exp < csp_zero_exp_value
THEN
    l.abs_exp  := 64 - l.exp
ELSE
    IF  l.exp  = csp_zero_exp_value
    THEN
        l.abs_exp := 0
    ELSE
        l.abs_exp  := l.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
IF  r.exp < csp_zero_exp_value
THEN
    r.abs_exp  := 64 - r.exp
ELSE
    IF  r.exp  = csp_zero_exp_value
    THEN
        r.abs_exp := 0
    ELSE
        r.abs_exp  := r.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
IF  l.exp = csp_zero_exp_value
THEN
    BEGIN
    sp51unpack (right, rpos, rlen, 0, r, ret);
    sp51pack (r, result, respos, reslen, resfrac, resbytelen, ret);
    END
ELSE
    BEGIN
    IF  r.exp = csp_zero_exp_value
    THEN
        BEGIN
        sp51unpack (left, lpos, llen, 0, l, ret);
        sp51pack (l, result,
              respos, reslen, resfrac, resbytelen, ret)
        END
    ELSE
        BEGIN
        IF  l.abs_exp > r.abs_exp
        THEN
            BEGIN
            sp51unpack (left,  lpos, llen, 0, l, ret);
            IF  ret = num_ok
            THEN
                sp51unpack (right, rpos, rlen,
                      l.abs_exp - r.abs_exp, r, ret);
            (*ENDIF*) 
            IF  r.exp = csp_zero_exp_value
            THEN
                BEGIN
                sp51pack (l, result, respos,
                      reslen, resfrac, resbytelen, ret);
                goto 999
                END;
            (*ENDIF*) 
            END
        ELSE
            BEGIN
            sp51unpack (right, rpos, rlen, 0, r, ret);
            IF  ret = num_ok
            THEN
                sp51unpack (left,  lpos, llen,
                      r.abs_exp - l.abs_exp, l, ret);
            (*ENDIF*) 
            IF  l.exp = csp_zero_exp_value
            THEN
                BEGIN
                sp51pack (r, result, respos,
                      reslen, resfrac, resbytelen, ret);
                goto 999
                END;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        IF  ret = num_ok
        THEN
            IF  r.dig_cnt  > l.dig_cnt
            THEN
                BEGIN
                sp51add  (r, l);
                sp51pack (r, result, respos,
                      reslen, resfrac, resbytelen, ret)
                END
            ELSE
                BEGIN
                sp51add  (l, r);
                sp51pack (l, result, respos,
                      reslen, resfrac, resbytelen, ret)
                END;
            (*ENDIF*) 
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
999 :;
&ifdef kdebug
sp51trace_result ('s51add      ', result, respos, resbytelen, ret)
&     endif
END; (* s51add *)
 
(*------------------------------*) 
 
PROCEDURE
      s51div (
            VAR left       : tsp00_MoveObj;
            lpos           : tsp00_Int4;
            llen           : integer;
            VAR right      : tsp00_MoveObj;
            rpos           : tsp00_Int4;
            rlen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      is_negative : boolean;
      l           : tsp51operand;
      r, res      : tsp51operand;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51div      ', left, lpos, llen, right, rpos, rlen);
&endif
l.exp      := ord (left  [lpos]);
r.exp      := ord (right [rpos]);
l.negative := l.exp < csp_zero_exp_value;
r.negative := r.exp < csp_zero_exp_value;
IF  r.exp = csp_zero_exp_value
THEN
    ret := num_overflow
ELSE
    BEGIN
    ret         := num_ok;
    is_negative := l.negative <> r.negative;
    IF  r.exp < csp_zero_exp_value
    THEN
        r.abs_exp  := 64 - r.exp
    ELSE
        r.abs_exp  := r.exp - 192;
    (*ENDIF*) 
    IF  l.exp < csp_zero_exp_value
    THEN
        l.abs_exp  := 64 - l.exp
    ELSE
        l.abs_exp  := l.exp - 192;
    (*ENDIF*) 
    sp51unpack (left,  lpos, llen, 0, l, ret);
    IF  ret = num_ok
    THEN
        BEGIN
        IF  l.negative
        THEN
            sp51compl (l);
        (*ENDIF*) 
        sp51unpack (right, rpos, rlen, 0, r, ret);
        IF  ret = num_ok
        THEN
            BEGIN
            IF  r.negative
            THEN
                sp51compl (r);
            (*ENDIF*) 
            res.abs_exp := l.abs_exp - r.abs_exp + 1;
            sp51div (l, r, csp51_max_digits, res);
            IF  is_negative
            THEN
                sp51compl (res)
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    sp51pack (res, result, respos, reslen, resfrac, resbytelen, ret)
    END;
(*ENDIF*) 
&ifdef kdebug
sp51trace_result ('s51div      ', result, respos, resbytelen, ret)
&     endif
END; (* s51div *)
 
(*------------------------------*) 
 
FUNCTION
      s51floatlen (
            VAR source   : tsp00_MoveObj;
            spos         : tsp00_Int4;
            slen         : integer) : integer;
 
VAR
      p : tsp00_Int4;
 
BEGIN
IF  source[spos] = chr (0)
THEN (* no legal sqldb number *)
    s51floatlen := 0
ELSE
    BEGIN
    p := spos + slen - 1;
    WHILE source [p] = chr(0) DO
        p := p - 1;
    (*ENDWHILE*) 
    IF  (ord (source [p]) MOD 16 = 0) AND (p > spos)
    THEN
        s51floatlen := 2 * (p - spos) - 1
    ELSE
        s51floatlen := 2 * (p - spos)
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* s51floatlen *)
 
(*------------------------------*) 
 
PROCEDURE
      s51intdiv (
            VAR left       : tsp00_MoveObj;
            lpos           : tsp00_Int4;
            llen           : integer;
            VAR right      : tsp00_MoveObj;
            rpos           : tsp00_Int4;
            rlen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      is_negative : boolean;
      l           : tsp51operand;
      r, res      : tsp51operand;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51intdiv   ', left, lpos, llen, right, rpos, rlen);
&endif
l.exp      := ord (left  [lpos]);
r.exp      := ord (right [rpos]);
l.negative := l.exp < csp_zero_exp_value;
r.negative := r.exp < csp_zero_exp_value;
IF  r.exp = csp_zero_exp_value
THEN
    ret := num_overflow
ELSE
    BEGIN
    ret         := num_ok;
    is_negative := l.negative <> r.negative;
    IF  r.exp < csp_zero_exp_value
    THEN
        r.abs_exp  := 64 - r.exp
    ELSE
        r.abs_exp  := r.exp - 192;
    (*ENDIF*) 
    IF  l.exp < csp_zero_exp_value
    THEN
        l.abs_exp  := 64 - l.exp
    ELSE
        l.abs_exp  := l.exp - 192;
    (*ENDIF*) 
    sp51unpack (left,  lpos, llen, 0, l, ret);
    IF  ret = num_ok
    THEN
        BEGIN
        IF  l.negative
        THEN
            sp51compl (l);
        (*ENDIF*) 
        sp51unpack (right, rpos, rlen, 0, r, ret);
        IF  ret = num_ok
        THEN
            BEGIN
            IF  r.negative
            THEN
                sp51compl (r);
            (*ENDIF*) 
            IF  ((l.exp = csp_zero_exp_value) OR
                ((l.abs_exp >  0)               AND
                (l.abs_exp <= csp51_max_digits) AND
                (l.dig_cnt <= l.abs_exp)))      AND
                (r.abs_exp >  0)                AND
                (r.abs_exp <= csp51_max_digits) AND
                (r.dig_cnt <= r.abs_exp)
            THEN
                BEGIN
                (* divident and divisor are integer numbers *)
                res.abs_exp := l.abs_exp - r.abs_exp + 1;
                sp51div   (l, r, res.abs_exp, res);
&               ifdef kdebug
                sp51wop (res);
&               endif
                IF  res.dig_cnt > res.abs_exp
                THEN
                    BEGIN
                    res.lo      := res.lo + res.dig_cnt - res.abs_exp;
                    res.dig_cnt := res.abs_exp
                    END;
                (*ENDIF*) 
                IF  is_negative
                THEN
                    sp51compl (res)
                (*ENDIF*) 
                END
            ELSE
                ret := num_invalid;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    sp51pack (res, result, respos, reslen, resfrac, resbytelen, ret)
    END;
(*ENDIF*) 
&ifdef kdebug
sp51trace_result ('s51intdiv   ', result, respos, resbytelen, ret)
&     endif
END; (* s51intdiv *)
 
(*------------------------------*) 
 
PROCEDURE
      s51isint (
            VAR source : tsp00_MoveObj;
            spos       : tsp00_Int4;
            slen       : integer;
            VAR isint  : boolean;
            VAR ret    : tsp00_NumError);
 
VAR
      exp     : integer;
      p       : tsp00_Int4;
      dig_cnt : integer;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51isint    ', source, spos, slen, source, -1, -1);
&endif
ret := num_ok;
exp := ord (source [spos]);
IF  exp = csp_zero_exp_value
THEN
    isint := true
ELSE
    IF  exp = 0
    THEN
        BEGIN
        isint := false;
        ret   := num_invalid
        END
    ELSE
        BEGIN
        IF  exp < csp_zero_exp_value
        THEN
            exp := 64 - exp
        ELSE
            exp := exp - 192;
        (*ENDIF*) 
        p := spos + slen - 1;
        WHILE source [p] = chr(0) DO
            p := p - 1;
        (*ENDWHILE*) 
        IF  ord (source [p]) MOD 16 = 0
        THEN
            dig_cnt := 2 * (p - spos) - 1
        ELSE
            dig_cnt := 2 * (p - spos);
        (*ENDIF*) 
        isint := (exp >  0)             AND
              (exp <= csp51_max_digits) AND
              (dig_cnt <= exp)
        END
    (*ENDIF*) 
(*ENDIF*) 
END; (* s51isint *)
 
(*------------------------------*) 
 
PROCEDURE
      s51kroun (
            VAR source     : tsp00_MoveObj;
            spos           : tsp00_Int4;
            slen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      op : tsp51operand;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51kroun    ', source, spos, slen, source, -1, -1);
t01int4      (39, 'reslen      ', reslen);
t01int4      (39, 'resfrac     ', resfrac);
&endif
IF  resfrac = csp_float_frac
THEN
    BEGIN
    ret         := num_ok;
    op.exp      := ord (source [spos]);
    op.negative := op.exp < csp_zero_exp_value;
    IF  op.exp < csp_zero_exp_value
    THEN
        op.abs_exp := 64 - op.exp
    ELSE
        IF  op.exp = csp_zero_exp_value
        THEN
            op.abs_exp := 0
        ELSE
            op.abs_exp  := op.exp - 192;
        (*ENDIF*) 
    (*ENDIF*) 
    sp51unpack (source, spos, slen, 0, op, ret);
    IF  ret = num_ok
    THEN
        sp51round  (op, reslen + 1, op.lo);
    (*ENDIF*) 
    sp51pack   (op, result, respos, reslen, resfrac, resbytelen, ret)
    END
ELSE
    s51round (source, spos, slen, resfrac,
          result, respos, reslen, resfrac, resbytelen, ret)
&         ifdef kdebug
          ;
(*ENDIF*) 
sp51trace_result ('s51kroun    ', result, respos, resbytelen, ret)
&     endif
END; (* s51kroun *)
 
(*------------------------------*) 
 
PROCEDURE
      s51mul (
            VAR left       : tsp00_MoveObj;
            lpos           : tsp00_Int4;
            llen           : integer;
            VAR right      : tsp00_MoveObj;
            rpos           : tsp00_Int4;
            rlen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      l   : tsp51operand;
      r   : tsp51operand;
      res : tsp51operand;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51mul      ', left, lpos, llen, right, rpos, rlen);
&endif
ret        := num_ok;
l.exp      := ord (left [lpos]);
r.exp      := ord (right [rpos]);
l.negative := l.exp < csp_zero_exp_value;
r.negative := r.exp < csp_zero_exp_value;
IF  l.exp < csp_zero_exp_value
THEN
    l.abs_exp  := 64 - l.exp
ELSE
    IF  l.exp  = csp_zero_exp_value
    THEN
        l.abs_exp := 0
    ELSE
        l.abs_exp  := l.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
IF  r.exp < csp_zero_exp_value
THEN
    r.abs_exp  := 64 - r.exp
ELSE
    IF  r.exp  = csp_zero_exp_value
    THEN
        r.abs_exp := 0
    ELSE
        r.abs_exp  := r.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
IF  l.exp = csp_zero_exp_value
THEN
    BEGIN
    sp51unpack (left, lpos, llen, 0, l, ret);
    IF  ret = num_ok
    THEN
        sp51pack (l, result,
              respos, reslen, resfrac, resbytelen, ret)
    (*ENDIF*) 
    END
ELSE
    BEGIN
    IF  r.exp = csp_zero_exp_value
    THEN
        BEGIN
        sp51unpack (right, rpos, rlen, 0, r, ret);
        IF  ret = num_ok
        THEN
            sp51pack (r, result,
                  respos, reslen, resfrac, resbytelen, ret)
        (*ENDIF*) 
        END
    ELSE
        BEGIN
        res.negative := l.negative <> r.negative;
        sp51unpack (left,  lpos, llen, 0, l, ret);
        IF  ret = num_ok
        THEN
            BEGIN
            IF  l.negative
            THEN
                sp51compl (l);
            (*ENDIF*) 
            sp51unpack (right, rpos, rlen, 0, r, ret);
            IF  ret = num_ok
            THEN
                IF  r.negative
                THEN
                    sp51compl (r);
                (*ENDIF*) 
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        IF  ret = num_ok
        THEN
            BEGIN
            IF  l.dig_cnt > r.dig_cnt
            THEN
                sp51mult (l, r, res)
            ELSE
                sp51mult (r, l, res);
            (*ENDIF*) 
            res.lo := 1;
            res.hi := res.dig_cnt;
            WHILE res.digits[res.lo] = 0 DO
                BEGIN
                res.lo      := res.lo + 1;
                res.dig_cnt := res.dig_cnt - 1
                END;
            (*ENDWHILE*) 
            IF  res.negative
            THEN
                BEGIN
                res.exp := 64 - res.abs_exp;
                res.negative := false;
                sp51compl (res);
                END
            ELSE
                res.exp := 192 + res.abs_exp;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        sp51pack (res, result, respos, reslen, resfrac, resbytelen, ret)
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
&ifdef kdebug
sp51trace_result ('s51mul      ', result, respos, resbytelen, ret)
&     endif
END; (* s51mul *)
 
(*------------------------------*) 
 
PROCEDURE
      s51neg (
            VAR source     : tsp00_MoveObj;
            spos           : tsp00_Int4;
            slen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      op : tsp51operand;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51neg      ', source, spos, slen, source, -1, -1);
&endif
ret         := num_ok;
op.exp      := ord (source [spos]);
op.negative := op.exp < csp_zero_exp_value;
IF  op.exp < csp_zero_exp_value
THEN
    op.abs_exp  := 64 - op.exp
ELSE
    IF  op.exp  = csp_zero_exp_value
    THEN
        op.abs_exp := 0
    ELSE
        op.abs_exp  := op.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
sp51unpack (source, spos, slen, 0, op, ret);
IF  ret = num_ok
THEN
    sp51compl  (op);
(*ENDIF*) 
sp51pack   (op, result, respos, reslen, resfrac, resbytelen, ret)
&     ifdef kdebug
      ;
sp51trace_result ('s51neg      ', result, respos, resbytelen, ret)
&     endif
END; (* s51neg *)
 
(*------------------------------*) 
 
PROCEDURE
      s51power (
            VAR base       : tsp00_MoveObj;
            basepos        : tsp00_Int4;
            baselen        : integer;
            basefrac       : integer;
            VAR power      : tsp00_MoveObj;
            ppos           : tsp00_Int4;
            plen           : integer;
            pfrac          : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
BEGIN
s52power (base, basepos, baselen, basefrac,
      power, ppos, plen, pfrac, result, respos, reslen, resfrac, ret);
resbytelen := (reslen + 1) DIV 2 + 1
END; (* s51power *)
 
(*------------------------------*) 
 
PROCEDURE
      s51round (
            VAR source     : tsp00_MoveObj;
            spos           : tsp00_Int4;
            slen           : integer;
            round          : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      round_pos : integer;
      op        : tsp51operand;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51round    ', source, spos, slen, source, -1, -1);
&endif
ret         := num_ok;
op.exp      := ord (source [spos]);
op.negative := op.exp < csp_zero_exp_value;
IF  op.exp < csp_zero_exp_value
THEN
    op.abs_exp  := 64 - op.exp
ELSE
    IF  op.exp  = csp_zero_exp_value
    THEN
        op.abs_exp := 0
    ELSE
        op.abs_exp  := op.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
sp51unpack (source, spos, slen, 0, op, ret);
IF  ret = num_ok
THEN
    BEGIN
    round_pos := op.abs_exp + round + 1;
    IF  round_pos < 0
    THEN
        sp51zero_result (op)
    ELSE
        IF  round < op.dig_cnt - op.abs_exp
        THEN
            sp51round (op, round_pos, op.lo);
        (*ENDIF*) 
    (*ENDIF*) 
    END;
(*ENDIF*) 
sp51pack (op, result, respos, reslen, resfrac, resbytelen, ret)
&     ifdef kdebug
      ;
sp51trace_result ('s51round    ', result, respos, resbytelen, ret)
&     endif
END; (* s51round *)
 
(*------------------------------*) 
 
PROCEDURE
      s51scale (
            VAR vnumber : tsp00_Number;
            scale       : integer;
            VAR res     : tsp00_NumError);
 
VAR
      negativ : boolean;
      exp     : integer;
 
BEGIN
res := num_ok;
negativ := false;
exp := ord (vnumber  [ 1 ]);
IF  exp < csp_zero_exp_value
THEN
    BEGIN
    exp := 256 - exp;
    negativ := true;
    END;
(*ENDIF*) 
IF  exp > csp_zero_exp_value
THEN
    BEGIN
    exp := exp + scale;
    IF  (exp >= 256) OR (exp <= csp_zero_exp_value)
    THEN
        res := num_overflow
    ELSE
        BEGIN
        IF  negativ
        THEN
            exp := 256 - exp;
        (*ENDIF*) 
        vnumber  [ 1 ] := chr (exp);
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* s51scale *)
 
(*------------------------------*) 
 
PROCEDURE
      s51sqrt (
            VAR source     : tsp00_MoveObj;
            spos           : tsp00_Int4;
            slen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
BEGIN
s52sqrt (source, spos, slen, result, respos, reslen, resfrac, ret);
resbytelen := (reslen + 1) DIV 2 + 1
END; (* s51sqrt *)
 
(*------------------------------*) 
 
PROCEDURE
      s51sub (
            VAR left       : tsp00_MoveObj;
            lpos           : tsp00_Int4;
            llen           : integer;
            VAR right      : tsp00_MoveObj;
            rpos           : tsp00_Int4;
            rlen           : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      l, r : tsp51operand;
 
LABEL
      999;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51sub      ', left, lpos, llen, right, rpos, rlen);
&endif
ret        := num_ok;
l.exp      := ord (left [lpos]);
r.exp      := ord (right [rpos]);
l.negative := l.exp < csp_zero_exp_value;
r.negative := r.exp < csp_zero_exp_value;
IF  l.exp < csp_zero_exp_value
THEN
    l.abs_exp  := 64 - l.exp
ELSE
    IF  l.exp  = csp_zero_exp_value
    THEN
        l.abs_exp := 0
    ELSE
        l.abs_exp  := l.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
IF  r.exp < csp_zero_exp_value
THEN
    r.abs_exp  := 64 - r.exp
ELSE
    IF  r.exp  = csp_zero_exp_value
    THEN
        r.abs_exp := 0
    ELSE
        r.abs_exp  := r.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
IF  l.exp = csp_zero_exp_value
THEN
    BEGIN
    sp51unpack (right, rpos, rlen, 0, r, ret);
    IF  ret = num_ok
    THEN
        sp51compl (r);
    (*ENDIF*) 
    sp51pack (r, result, respos, reslen, resfrac, resbytelen, ret)
    END
ELSE
    BEGIN
    IF  r.exp = csp_zero_exp_value
    THEN
        BEGIN
        sp51unpack (left, lpos, llen, 0, l, ret);
        sp51pack (l, result,
              respos, reslen, resfrac, resbytelen, ret)
        END
    ELSE
        BEGIN
        IF  l.abs_exp > r.abs_exp
        THEN
            BEGIN
            sp51unpack (left,  lpos, llen, 0, l, ret);
            IF  ret = num_ok
            THEN
                sp51unpack (right, rpos, rlen,
                      l.abs_exp - r.abs_exp, r, ret);
            (*ENDIF*) 
            IF  r.exp = csp_zero_exp_value
            THEN
                BEGIN
                sp51pack (l, result,
                      respos, reslen, resfrac, resbytelen, ret);
                goto 999
                END;
            (*ENDIF*) 
            END
        ELSE
            BEGIN
            sp51unpack (right, rpos, rlen, 0, r, ret);
            IF  ret = num_ok
            THEN
                sp51unpack (left,  lpos, llen,
                      r.abs_exp - l.abs_exp, l, ret);
            (*ENDIF*) 
            IF  l.exp = csp_zero_exp_value
            THEN
                BEGIN
                sp51compl (r);
                sp51pack (r, result,
                      respos, reslen, resfrac, resbytelen, ret);
                goto 999
                END;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        IF  ret = num_ok
        THEN
            BEGIN
            sp51compl (r);
            IF  r.dig_cnt  > l.dig_cnt
            THEN
                BEGIN
                sp51add  (r, l);
                sp51pack (r, result, respos,
                      reslen, resfrac, resbytelen, ret)
                END
            ELSE
                BEGIN
                sp51add  (l, r);
                sp51pack (l, result, respos,
                      reslen, resfrac, resbytelen, ret)
                END;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
999 : ;
&ifdef kdebug
sp51trace_result ('s51sub      ', result, respos, resbytelen, ret)
&     endif
END; (* s51sub *)
 
(*------------------------------*) 
 
PROCEDURE
      s51trunc (
            VAR source     : tsp00_MoveObj;
            spos           : tsp00_Int4;
            slen           : integer;
            trunc          : integer;
            VAR result     : tsp00_MoveObj;
            respos         : tsp00_Int4;
            reslen         : integer;
            resfrac        : integer;
            VAR resbytelen : integer;
            VAR ret        : tsp00_NumError);
 
VAR
      negative  : boolean;
      trunc_pos : integer;
      op        : tsp51operand;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51trunc    ', source, spos, slen, source, -1, -1);
&endif
ret         := num_ok;
op.exp      := ord (source [spos]);
negative    := op.exp < csp_zero_exp_value;
op.negative := negative;
IF  op.exp < csp_zero_exp_value
THEN
    op.abs_exp  := 64 - op.exp
ELSE
    IF  op.exp = csp_zero_exp_value
    THEN
        op.abs_exp := 0
    ELSE
        op.abs_exp  := op.exp - 192;
    (*ENDIF*) 
(*ENDIF*) 
sp51unpack (source, spos, slen, 0, op, ret);
IF  ret = num_ok
THEN
    BEGIN
    IF  negative
    THEN
        sp51compl (op);
    (*ENDIF*) 
    trunc_pos := op.abs_exp + trunc + 1;
    IF  trunc_pos < 0
    THEN
        sp51zero_result (op)
    ELSE
        IF  trunc < op.dig_cnt - op.abs_exp
        THEN
            BEGIN
            op.lo      := op.dig_cnt - trunc_pos + 2;
            op.dig_cnt := op.dig_cnt - op.lo + 1
            END;
        (*ENDIF*) 
    (*ENDIF*) 
    IF  negative
    THEN
        sp51compl (op)
    (*ENDIF*) 
    END;
(*ENDIF*) 
sp51pack (op, result, respos, reslen, resfrac, resbytelen, ret)
&     ifdef kdebug
      ;
sp51trace_result ('s51trunc    ', result, respos, resbytelen, ret)
&     endif
END; (* s51trunc *)
 
(*------------------------------*) 
 
PROCEDURE
      sp51add (
            VAR op1 : tsp51operand;
            VAR op2 : tsp51operand);
 
VAR
      op1_lo         : integer;
      op2_lo         : integer;
      dig            : integer;
      i              : integer;
      carry          : integer;
 
BEGIN
&ifdef kdebug
sp51wop (op1);
sp51wop (op2);
&endif
op2_lo := op2.lo;
carry  := 0;
FOR op1_lo := op1.lo + op1.dig_cnt - op2.dig_cnt TO op1.hi + 1 DO
    BEGIN
    dig := op2.digits [op2_lo] + op1.digits [op1_lo] + carry;
    IF  dig > 9
    THEN
        BEGIN
        carry := 1;
        dig   := dig - 10
        END
    ELSE
        carry := 0;
    (*ENDIF*) 
    op1.digits [op1_lo] := dig;
    op2_lo              := op2_lo + 1
    END;
(*ENDFOR*) 
op1.digits[op1.hi+2] := 1;
WHILE op1.digits[op1.lo] = 0 DO
    op1.lo := op1.lo + 1;
(*ENDWHILE*) 
IF  dig > 5
THEN
    BEGIN
    op1.negative := true;
    op1.exp      := 64 - op2.abs_exp - 1;
    i            := op1.hi + 1;
    WHILE op1.digits [i] = 9 DO
        BEGIN
        i       := i - 1;
        op1.exp := op1.exp + 1;
        END;
    (*ENDWHILE*) 
    IF  i < op1.lo
    THEN
        BEGIN
        op1.digits [1] := 9;
        op1.dig_cnt    := 1;
        op1.exp        := op1.exp - 1
        END
    ELSE
        BEGIN
        op1.dig_cnt    := i - op1.lo + 1;
        op1.digits [0] := 0;
        END;
    (*ENDIF*) 
    op1.abs_exp := 64 - op1.exp
    END
ELSE
    BEGIN
    op1.negative   := false;
    op1.digits [0] := 9;
    op1.exp        := 192 + op2.abs_exp + 1;
    i              := op1.hi + 1;
    WHILE op1.digits [i] = 0 DO
        BEGIN
        i       := i - 1;
        op1.exp := op1.exp - 1
        END;
    (*ENDWHILE*) 
    op1.abs_exp := op1.exp - 192;
    IF  i < op1.lo
    THEN
        sp51zero_result (op1)
    ELSE
        BEGIN
        op1.digits [0] := 0;
        op1.dig_cnt    := i - op1.lo + 1;
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
&ifdef kdebug
sp51wop (op1);
&endif
END; (* sp51add *)
 
(*------------------------------*) 
 
PROCEDURE
      sp51compl (
            VAR op : tsp51operand);
 
VAR
      i : integer;
 
BEGIN
IF  op.exp <> csp_zero_exp_value
THEN
    BEGIN
    op.digits [op.lo] := 10 - op.digits [op.lo];
    FOR i := op.lo + 1 TO op.hi DO
        op.digits [i] := 9 - op.digits [i];
    (*ENDFOR*) 
    IF  op.negative
    THEN
        BEGIN
        op.negative         := false;
        op.exp              := 192 + op.abs_exp;
        op.digits [op.hi+1] := 0
        END
    ELSE
        BEGIN
        op.negative         := true;
        op.exp              := 64 - op.abs_exp;
        op.digits [op.hi+1] := 9
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* sp51compl *)
 
(*------------------------------*) 
 
PROCEDURE
      sp51div (
            VAR l          : tsp51operand;
            VAR r          : tsp51operand;
            max_res_digits : integer;
            VAR res        : tsp51operand);
 
VAR
      li        : integer;
      nli       : integer;
      carry     : integer;
      diff      : integer;
      res_dig   : integer;
      i         : integer;
      j         : integer;
      l_dig     : integer;
      nl_dig    : integer;
      l_dig_cnt : integer;
      r_dig     : integer;
      r_dig_cnt : integer;
      abs_r_cnt : integer;
      r_left_dig: integer;
      lo        : integer;
 
BEGIN
&ifdef kdebug
t01int4 (39, 'sp51div     ', 1);
t01int4 (39, 'maxresdigits', max_res_digits);
&endif
res.negative := false;
IF  (l.exp = csp_zero_exp_value) OR (max_res_digits <= 0)
THEN
    sp51zero_result (res)
ELSE
    BEGIN
    l_dig_cnt    := l.dig_cnt;
    r_dig_cnt    := r.dig_cnt;
    abs_r_cnt    := r_dig_cnt;
    FOR i := 1 TO l_dig_cnt - r_dig_cnt DO
        l.digits[csp51_intern_numblen + i] := l.digits[i];
    (*ENDFOR*) 
    l.digits[0]                    := -1;
    l.digits[csp51_intern_numblen] := -1;
    li                 := 0;
    nli                := csp51_intern_numblen;
    res.hi             := csp51_intern_numblen * 2;
    lo                 := csp51_numblen;
&   ifdef kdebug
    sp51wop (l);
    sp51wop (r);
&   endif
    REPEAT
        lo         := lo - 1;
        carry      := 0;
        res_dig    := -1;
        r_left_dig := r.digits[r_dig_cnt];
        REPEAT
            (* in this loop the divisor is substracted from the     *)
            (* divident until the result is negative. The number of *)
            (* loop executions is the current digit of the quotient *)
            res_dig := res_dig + 1;
            IF  (r_left_dig = 0) AND
                (l.digits[li + l_dig_cnt] = 0)
            THEN
                BEGIN
                (* truncate leading zeros of divident and divisor *)
                REPEAT
                    l_dig_cnt := l_dig_cnt - 1;
                    r_dig_cnt := r_dig_cnt - 1
                UNTIL
                    (l.digits[li + l_dig_cnt] <> 0) OR
                    (r.digits[r_dig_cnt] <> 0);
                (*ENDREPEAT*) 
                r_left_dig := r.digits[r_dig_cnt]
                END;
            (*ENDIF*) 
            IF  (r_left_dig > l.digits[li + l_dig_cnt]) OR
                (res_dig = 9)
            THEN
                BEGIN
                (* divisor is greater than divident, exit loop by    *)
                (* setting carry to 1, which means, that the divisor *)
                (* will be divided by 10 by the outer loop           *)
                j     := li;
                li    := nli;
                nli   := j;
                carry := 1
                END
            ELSE
                BEGIN
                r_dig := 1;
                IF  l_dig_cnt < r_dig_cnt
                THEN
                    BEGIN
                    (* r has more digits than l, the missing digits *)
                    (* are treated as 0's                           *)
                    nl_dig := nli;
                    FOR i := l_dig_cnt TO r_dig_cnt - 1 DO
                        BEGIN
                        nl_dig := nl_dig + 1;
                        IF  (carry > 0) OR (r.digits[r_dig] > 0)
                        THEN
                            BEGIN
                            l.digits[nl_dig] :=
                                  10 - (r.digits[r_dig] + carry);
                            carry   := 1
                            END
                        ELSE
                            BEGIN
                            l.digits[nl_dig] := 0;
                            carry := 0
                            END;
                        (*ENDIF*) 
                        r_dig  := r_dig + 1;
                        END;
                    (*ENDFOR*) 
                    l_dig := li
                    END
                ELSE
                    BEGIN
                    l_dig  := li  + l_dig_cnt - r_dig_cnt;
                    nl_dig := nli + l_dig_cnt - r_dig_cnt
                    END;
                (*ENDIF*) 
                WHILE l_dig < li + l_dig_cnt DO
                    BEGIN
                    l_dig  := l_dig + 1;
                    nl_dig := nl_dig + 1;
                    diff   := l.digits[l_dig] -
                          (r.digits[r_dig] + carry);
                    IF  diff < 0
                    THEN
                        BEGIN
                        l.digits[nl_dig] := diff + 10;
                        carry := 1
                        END
                    ELSE
                        BEGIN
                        l.digits[nl_dig] := diff;
                        carry := 0
                        END;
                    (*ENDIF*) 
                    r_dig := r_dig + 1
                    END;
                (*ENDWHILE*) 
                IF  (l_dig_cnt < r_dig_cnt) AND (carry = 0)
                THEN
                    l_dig_cnt := r_dig_cnt;
                (*ENDIF*) 
                IF  li = 0
                THEN
                    BEGIN
                    li  := csp51_intern_numblen;
                    nli := 0
                    END
                ELSE
                    BEGIN
                    li  := 0;
                    nli := csp51_intern_numblen
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
        UNTIL
            carry <> 0;
        (*ENDREPEAT*) 
        res.digits[lo] := res_dig;
        IF  li = 0
        THEN
            BEGIN
            li  := csp51_intern_numblen;
            nli := 0
            END
        ELSE
            BEGIN
            li  := 0;
            nli := csp51_intern_numblen
            END;
        (*ENDIF*) 
        abs_r_cnt := abs_r_cnt + 1;
        IF  l.digits[li + l_dig_cnt] = 0
        THEN
            l_dig_cnt := l_dig_cnt - 1
        ELSE
            BEGIN
            (* r := r div 10 *)
            IF  abs_r_cnt > csp51_intern_numblen
            THEN
                BEGIN
                (* truncate rightmost digit of divisor *)
                FOR i := 1 TO r_dig_cnt DO
                    r.digits[i] := r.digits[i+1];
                (*ENDFOR*) 
                r.digits[r_dig_cnt] := 0
                END
            ELSE
                BEGIN
                r_dig_cnt            := r_dig_cnt + 1;
                r.digits [r_dig_cnt] := 0;
                END;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
    UNTIL
        (l_dig_cnt = 0) OR (lo = csp51_intern_numblen * 2 - max_res_digits);
    (*ENDREPEAT*) 
    res.digits[0] := 1;
    WHILE res.digits[res.hi] = 0 DO
        BEGIN
        res.hi      := res.hi - 1;
        res.abs_exp := res.abs_exp - 1;
        END;
    (*ENDWHILE*) 
    res.exp     := 192 + res.abs_exp;
    WHILE res.digits[lo] = 0 DO
        lo := lo + 1;
    (*ENDWHILE*) 
    res.lo      := lo;
    res.dig_cnt := res.hi - lo + 1
    END;
(*ENDIF*) 
END; (* sp51div *)
 
(*------------------------------*) 
 
PROCEDURE
      sp51mult (VAR l : tsp51operand;
            VAR r     : tsp51operand;
            VAR res   : tsp51operand);
 
CONST
      mult_cluster_digits = 8;
 
VAR
      i          : integer;
      res_offset : integer;
      res_pos    : integer;
      r_pos      : integer;
      max        : integer;
      div10      : tsp00_Int4;
      power10    : tsp00_Int4;
      product    : tsp00_Int4;
      carry      : tsp00_Int4;
      mult       : tsp00_Int4;
 
BEGIN
res.digits [0] := 0;
IF  r.dig_cnt <= mult_cluster_digits
THEN
    res_offset := r.dig_cnt
ELSE
    res_offset := mult_cluster_digits;
(*ENDIF*) 
mult     := r.digits[1];
power10  := 10;
r_pos    := 2;
WHILE r_pos <= res_offset DO
    BEGIN
    mult    := mult + r.digits[r_pos] * power10;
    r_pos   := r_pos + 1;
    power10 := power10 * 10
    END;
(*ENDWHILE*) 
carry := 0;
FOR i := 1 TO l.hi DO
    BEGIN
    product       := l.digits [i] * mult + carry;
    carry         := product DIV 10;
    res.digits[i] := product - (10 * carry);
    END;
(*ENDFOR*) 
res_pos := l.hi;
WHILE carry > 0 DO
    BEGIN
    div10               := carry DIV 10;
    res_pos             := res_pos + 1;
    res.digits[res_pos] := carry - (div10 * 10);
    carry               := div10
    END;
(*ENDWHILE*) 
IF  r.dig_cnt > mult_cluster_digits
THEN
    BEGIN
    FOR i := res_pos + 1 TO csp51_numblen DO
        res.digits [i] := 0;
    (*ENDFOR*) 
    REPEAT
        max := r.dig_cnt - r_pos + 1;
        IF  max > mult_cluster_digits
        THEN
            max := r_pos + mult_cluster_digits
        ELSE
            max := r_pos + max;
        (*ENDIF*) 
        mult     := r.digits[r_pos];
        r_pos    := r_pos + 1;
        power10  := 10;
        WHILE r_pos < max DO
            BEGIN
            mult    := mult + r.digits[r_pos] * power10;
            r_pos   := r_pos + 1;
            power10 := power10 * 10
            END;
        (*ENDWHILE*) 
        carry   := 0;
        res_pos := res_offset;
        FOR i := 1 TO l.hi DO
            BEGIN
            product       := res.digits[res_offset+i] +
                  l.digits [i] * mult + carry;
            carry               := product DIV 10;
            res_pos             := res_pos + 1;
            res.digits[res_pos] := product - (10 * carry)
            END;
        (*ENDFOR*) 
        WHILE carry > 0 DO
            BEGIN
            div10               := carry DIV 10;
            res_pos             := res_pos + 1;
            res.digits[res_pos] := carry - (div10 * 10);
            carry               := div10
            END;
        (*ENDWHILE*) 
        res_offset := res_offset + mult_cluster_digits;
    UNTIL
        r_pos > r.dig_cnt;
    (*ENDREPEAT*) 
    END;
(*ENDIF*) 
res.dig_cnt := res_pos;
res.abs_exp := l.abs_exp + r.abs_exp -
      (l.dig_cnt + r.dig_cnt - res.dig_cnt)
END; (* sp51mult *)
 
(*------------------------------*) 
 
PROCEDURE
      sp51pack (
            VAR res             : tsp51operand;
            VAR result          : tsp00_MoveObj;
            VAR respos          : tsp00_Int4;
            VAR required_digits : integer;
            VAR required_frac   : integer;
            VAR resbytelen      : integer;
            VAR ret             : tsp00_NumError);
 
VAR
      res_frac : integer;
      j        : tsp00_Int4;
      i        : tsp00_Int4;
      last_dig : integer;
 
BEGIN
&ifdef kdebug
t01int4 (39, 'sp51pack    ', 1);
t01int4 (39, 'required_dig', required_digits);
t01int4 (39, 'requiredfrac', required_frac);
sp51wop (res);
&endif
resbytelen := (required_digits + 1) DIV 2 + 1;
last_dig   := res.lo;
IF  required_frac <> csp_float_frac
THEN
    IF  res.abs_exp > csp51_max_digits
    THEN
        ret := num_overflow
    ELSE
        BEGIN
        res_frac := res.dig_cnt - res.abs_exp;
        IF  (res.dig_cnt - res_frac) >
            (required_digits - required_frac)
        THEN
            ret := num_overflow
        ELSE
            IF  res_frac > required_frac
            THEN
                BEGIN
                ret := num_trunc;
                sp51round (res, res_frac - required_frac, last_dig);
                last_dig := res_frac - required_frac + 1
                END;
            (*ENDIF*) 
        (*ENDIF*) 
        END
    (*ENDIF*) 
ELSE
    IF  ((res.exp > 255) OR (res.exp < 1))
        AND
        (ret = num_ok)
    THEN
        ret := num_overflow;
    (*ENDIF*) 
(*ENDIF*) 
IF  (ret <> num_ok) AND (ret <> num_trunc)
THEN
    i := respos - 1
ELSE
    BEGIN
    IF  res.dig_cnt > required_digits
    THEN
        BEGIN
        IF  required_frac <> csp_float_frac
        THEN
            ret := num_trunc;
        (*ENDIF*) 
        sp51round (res, required_digits + 1, last_dig);
        last_dig := res.lo + (res.dig_cnt - required_digits)
        END;
    (*ENDIF*) 
    j := res.lo + res.dig_cnt - 1;
    i := respos;
    res.digits[last_dig-1] := 0;
    WHILE j >= last_dig DO
        BEGIN
        i := i + 1;
        result [i] := chr (res.digits [j] * 16 + res.digits [j - 1]) ;
        j := j - 2;
        END;
    (*ENDWHILE*) 
    IF  i = respos
    THEN
        result [respos] := csp_zero_exponent
    ELSE
        result [respos] := chr (res.exp)
    (*ENDIF*) 
    END;
(*ENDIF*) 
FOR j := i + 1 TO respos + resbytelen - 1 DO
    result [j] := chr(0)
(*ENDFOR*) 
END; (* sp51pack *)
 
(*------------------------------*) 
 
PROCEDURE
      sp51round (
            VAR res  : tsp51operand;
            roundpos : integer;
            last_dig : integer);
 
VAR
      i   : integer;
      cmp : integer;
 
BEGIN
&ifdef kdebug
t01int4 (39, 'sp51round   ', roundpos);
sp51wop (res);
&endif
IF  res.dig_cnt >= roundpos
THEN
    BEGIN
    roundpos := last_dig + res.dig_cnt - roundpos;
&   ifdef kdebug
    t01int4 (39, 'roundpos    ', roundpos);
&   endif
    IF  res.negative
    THEN
        BEGIN
        IF  roundpos = last_dig
        THEN
            cmp := 5
        ELSE
            cmp := 4;
        (*ENDIF*) 
        IF  res.digits [roundpos] <= cmp
        THEN
            BEGIN
            i := roundpos + 1;
            WHILE res.digits [i] = 0 DO
                i := i + 1;
            (*ENDWHILE*) 
            IF  i >= last_dig + res.dig_cnt
            THEN
                BEGIN
                res.exp     := res.exp - 1;
                res.abs_exp := res.abs_exp + 1;
                res.dig_cnt := res.dig_cnt + 1
                END;
            (*ENDIF*) 
            res.lo         := i;
            res.dig_cnt    := res.dig_cnt - (i - last_dig)
            END
        ELSE
            BEGIN
            i := roundpos + 1;
            WHILE res.digits [i] = 9 DO
                BEGIN
                res.digits [i] := 0;
                i := i + 1
                END;
            (*ENDWHILE*) 
            res.digits [i] := res.digits [i] + 1;
            res.lo         := i;
            res.dig_cnt    := res.dig_cnt - (i - last_dig)
            END
        (*ENDIF*) 
        END
    ELSE
        BEGIN
        IF  (res.digits [roundpos] >= 5)
        THEN
            BEGIN
            i := roundpos + 1;
            WHILE res.digits [i] = 9 DO
                BEGIN
                res.digits [i] := 0;
                i := i + 1
                END;
            (*ENDWHILE*) 
            res.digits [i] := res.digits [i] + 1;
            IF  i = last_dig + res.dig_cnt
            THEN
                BEGIN
                res.exp     := res.exp     + 1;
                res.abs_exp := res.abs_exp + 1;
                res.dig_cnt := res.dig_cnt + 1
                END;
            (*ENDIF*) 
            res.lo      := i;
            res.dig_cnt := res.dig_cnt - (i - last_dig)
            END
        ELSE
            BEGIN
            res.lo      := roundpos + 1;
            res.dig_cnt := res.dig_cnt - (res.lo - last_dig)
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* sp51round *)
 
(*------------------------------*) 
 
PROCEDURE
      sp51unpack (
            VAR op   : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            shift    : integer;
            VAR st   : tsp51operand;
            VAR ret  : tsp00_NumError);
 
VAR
      p    : tsp00_Int4;
      i, j : integer;
 
BEGIN
&ifdef kdebug
sp51trace_op ('s51unpack   ', op, pos, len, op, -1, -1);
&endif
IF  st.exp = 0
THEN
    ret := num_invalid
ELSE
    IF  (st.exp = csp_zero_exp_value) OR
        (shift > csp51_max_digits + 1)
    THEN
        sp51zero_result (st)
    ELSE
        BEGIN
        st.abs_exp    := st.abs_exp + shift;
        st.digits [0] := 0;
        p             := pos + len - 1;
        WHILE op [p] = chr(0) DO
            p := p - 1;
        (*ENDWHILE*) 
        st.digits [1] := ord (op [p]) MOD 16;
        IF  st.digits [1] <> 0
        THEN
            BEGIN
            i := 2;
            st.digits [2] := ord (op [p]) DIV 16
            END
        ELSE
            BEGIN
            i := 1;
            st.digits [1] := ord (op [p]) DIV 16
            END;
        (*ENDIF*) 
        pos := pos + 1;
        WHILE p > pos DO
            BEGIN
            p := p - 1;
            i := i + 1;
            st.digits [i] := ord (op [p]) MOD 16;
            i := i + 1;
            st.digits [i] := ord (op [p]) DIV 16;
            END;
        (*ENDWHILE*) 
        IF  st.negative
        THEN
            BEGIN
            FOR j := 1 TO shift + 1 DO
                BEGIN
                i := i + 1;
                st.digits [i] := 9;
                END;
            (*ENDFOR*) 
            END
        ELSE
            BEGIN
            FOR j := 1 TO shift + 1 DO
                BEGIN
                i := i + 1;
                st.digits [i] := 0;
                END;
            (*ENDFOR*) 
            END;
        (*ENDIF*) 
        i          := i - 1;
        st.hi      := i;
        st.lo      := 1;
        st.dig_cnt := i
        END;
    (*ENDIF*) 
(*ENDIF*) 
&ifdef kdebug
sp51wop (st);
&endif
END; (* sp51unpack *)
 
(*------------------------------*) 
 
PROCEDURE
      sp51zero_result (VAR res : tsp51operand);
 
BEGIN
res.exp     := csp_zero_exp_value;
res.abs_exp := 0;
res.lo      := 1;
res.hi      := 1;
res.dig_cnt := 0
END;
 
&ifdef kdebug
(*------------------------------*) 
 
PROCEDURE
      sp51wnumber (VAR m : tsp00_MoveObj;
            pos : tsp00_Int4;
            len : integer);
 
VAR
      i   : integer;
      j   : integer;
      val : integer;
 
      outline : RECORD
            CASE boolean OF
                true :
                    (c132 : tsp00_Line);
                false :
                    (c64 : tsp00_C64;
                    c48 : tsp00_C48;
                    c20 : tsp00_C20)
                END;
            (*ENDCASE*) 
 
 
BEGIN
WITH outline DO
    BEGIN
    c64 := bsp_c64;
    c48 := bsp_c48;
    c20 := bsp_c20;
    j   := 1;
    FOR i := 1 TO len DO
        BEGIN
        val := ord (m[pos+i-1]) DIV 16;
        IF  val >= 10
        THEN
            c132[j] := chr (val - 10 + ord ('A'))
        ELSE
            c132[j] := chr (val + ord ('0'));
        (*ENDIF*) 
        j := j + 1;
        val := ord (m[pos+i-1]) MOD 16;
        IF  val >= 10
        THEN
            c132[j] := chr (val - 10 + ord ('A'))
        ELSE
            c132[j] := chr (val + ord ('0'));
        (*ENDIF*) 
        j := j + 1
        END;
    (*ENDFOR*) 
    t01line (39, c132);
    END
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      sp51wop (VAR op : tsp51operand);
 
VAR
      i   : integer;
      j   : integer;
 
      outline : RECORD
            CASE boolean OF
                true :
                    (c132 : tsp00_Line);
                false :
                    (c64 : tsp00_C64;
                    c48 : tsp00_C48;
                    c20 : tsp00_C20)
                END;
            (*ENDCASE*) 
 
 
BEGIN
t01int4 (39, 'exp         ', op.exp);
t01int4 (39, 'abs_exp     ', op.abs_exp);
t01int4 (39, 'negative    ', ord (op.negative));
t01int4 (39, 'dig_cnt     ', op.dig_cnt);
t01int4 (39, 'hi          ', op.hi);
t01int4 (39, 'lo          ', op.lo);
WITH outline DO
    BEGIN
    c64 := bsp_c64;
    c48 := bsp_c48;
    c20 := bsp_c20;
    j   := 1;
    FOR i := op.lo + op.dig_cnt - 1 DOWNTO op.lo DO
        BEGIN
        IF  op.digits[i] < 10
        THEN
            c132[j] := chr (op.digits[i] + ord ('0'))
        ELSE
            c132[j] := chr (op.digits[i] - 10 + ord ('A'));
        (*ENDIF*) 
        j := j + 1;
        END;
    (*ENDFOR*) 
    t01line (39, c132);
    END
(*ENDWITH*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      sp51trace_op (txt : tsp00_Sname;
            VAR op1 : tsp00_MoveObj;
            p1      : tsp00_Int4;
            l1      : integer;
            VAR op2 : tsp00_MoveObj;
            p2      : tsp00_Int4;
            l2      : integer);
 
BEGIN
t01sname (39, txt);
sp51wnumber (op1, p1, l1);
IF  p2 > 0
THEN
    sp51wnumber (op2, p2, l2)
(*ENDIF*) 
END;
 
(*------------------------------*) 
 
PROCEDURE
      sp51trace_result (txt : tsp00_Sname;
            VAR result : tsp00_MoveObj;
            respos     : tsp00_Int4;
            reslen     : integer;
            ret        : tsp00_NumError);
 
BEGIN
t01sname (39, txt);
sp51wnumber (result, respos, reslen);
CASE ret OF
    num_ok :
        t01sname (39, 'num_ok      ');
    num_trunc :
        t01sname (39, 'num_trunc   ');
    num_overflow :
        t01sname (39, 'num_overflow');
    num_invalid  :
        t01sname (39, 'num_invalid ');
    OTHERWISE
        t01sname (39, 'unexpected e');
    END;
(*ENDCASE*) 
END;
 
&endif
 
.CM *-END-* code ----------------------------------------
.SP 2 
***********************************************************
.PA 
