.CM  SCRIPT , Version - 1.1 , last edited by Manuela Rathmann
.ad 8
.bm 8
.fm 4
.bt $Copyright (c) 1999-2005 SAP AG$$Page %$
.tm 12
.hm 6
.hs 3
.TT 1 $SQL$Project Distributed Database System$VSP40$
.tt 2 $$$
.TT 3 $$Conversions from VDN-Numbers$1999-11-22$
***********************************************************
.nf
 
.nf
 
.nf
 
    ========== licence begin  GPL
    Copyright (c) 1999-2005 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
 
 
.fo
.nf
.sp
MODULE  :  GET-Conversions
=========
.sp
Purpose : Conversion from VDN-Numbers
.CM *-END-* purpose -------------------------------------
.sp
.cp 3
Define  :
 
        PROCEDURE
              s40check (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40gsint (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR dest : tsp00_Int2;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40gsuns (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR dest : tsp00_Int2;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40glint (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR dest : tsp00_Int4;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40g4int (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    VAR dest : tsp00_Int4;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40g8int (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR dest : tsp00_Longint;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40gluns (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR dest : tsp00_Int4;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40gsrel (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR dest : tsp00_Shortreal;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40glrel (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR dest : tsp00_Longreal;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40gdec (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    VAR dest : tsp00_Decimal;
                    dlen     : integer;
                    dfrac    : integer;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40gzone (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    frac     : integer;
                    VAR dest : tsp00_Zoned;
                    dlen     : integer;
                    dfrac    : integer;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40glzon (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    frac     : integer;
                    VAR dest : tsp00_Zoned;
                    dlen     : integer;
                    dfrac    : integer;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40glszo (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    frac     : integer;
                    VAR dest : tsp00_Zoned;
                    dlen     : integer;
                    dfrac    : integer;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40gtszo (
                    VAR buf  : tsp00_MoveObj;
                    pos      : tsp00_Int4;
                    len      : integer;
                    frac     : integer;
                    VAR dest : tsp00_Zoned;
                    dlen     : integer;
                    dfrac    : integer;
                    VAR res  : tsp00_NumError);
 
        PROCEDURE
              s40gbyte (
                    VAR buf        : tsp00_MoveObj;
                    pos            : tsp00_Int4;
                    len            : integer;
                    VAR dest       : tsp00_MoveObj;
                    dpos           : tsp00_Int4;
                    dlen           : integer;
                    VAR truncated  : boolean);
 
.CM *-END-* define --------------------------------------
.sp;.cp 3
Use     :
 
.CM *-END-* use -----------------------------------------
.sp;.cp 3
Synonym :
 
.CM *-END-* synonym -------------------------------------
.sp;.cp 3
Author  : RudolfM
.sp
.cp 3
Created : 1984-07-25
.sp
.cp 3
.sp
.cp 3
Release :      Date : 1999-11-22
.sp
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Specification:
 
Possible conversions:
.sp;.nf
From VDN number  to SHORTINT      : S40GSINT
From VDN number  to UNSIGNED*2    : S40GSUNS
From VDN number  to LONGINT       : S40GLINT
From VDN number  to 4-Byte-INT    : S40G4INT ( from exact fixed(10,0))
From VDN number  to 8-Byte-INT    : S40G8INT
From VDN number  to UNSIGNED*4    : S40GLUNS
From VDN number  to SHORTREAL     : S40GSREL
From VDN number  to LONGREAL      : S40GLREL
From VDN number  to DECIMAL       : S40GDEC
From VDN number  to ZONED         : S40GZONE
FROM VDN number  to ZONED
            with leading sign     :  S40GLZON
FROM VDN number  to ZONED with
leading sign in separate position :  S40GLSZO
FROM VDN number  to ZONED with
trailing sign in separate position:  S40GTSZO
From byte string to STRING        : S40GBYTE
.sp;.fo
The following constant and type declarations apply:
.sp;.nf
CONST
      maxdeclength   = 10;
      maxzonedlength = 18;
      float_frac     = - 1;
 
      csp_comlint           = '\CA\21\47\48\36\48\00\00\00\00';
      csp_maxlint           = '\CA\21\47\48\36\47\00\00\00\00';
      csp_minlint           = '\36\78\52\51\63\52\00\00\00\00';
      csp_comsint           = '\C5\32\76\80\00\00\00\00\00\00';
      csp_maxsint           = '\C5\32\76\70\00\00\00\00\00\00';
      csp_minsint           = '\3B\67\23\20\00\00\00\00\00\00';
      csp_comluns           = '\CA\42\94\96\72\96\00\00\00\00';
      csp_maxluns           = '\CA\42\94\96\72\95\00\00\00\00';
      csp_minluns           = '\80\00\00\00\00\00\00\00\00\00';
      csp_comsuns           = '\C5\65\53\60\00\00\00\00\00\00';
      csp_maxsuns           = '\C5\65\53\50\00\00\00\00\00\00';
      csp_minsuns           = '\80\00\00\00\00\00\00\00\00\00';
      csp_maxsrel           = '\E7\34\02\82\00\00\00\00\00\00';
      csp_minsrel           = '\9B\11\75\49\00\00\00\00\00\00';
 
TYPE
      tsp00_Int2      = (* 2 Byte Integer *);
      tsp00_Int4      = (* 4 Byte Integer *);
      tsp00_Shortreal = (* 4 Byte Real *);
      tsp00_Longreal  = (* 8 Byte Real *);
      tsp00_Decimal   = PACKED ARRAY [  1..maxdeclength  ] OF char;
      tsp00_Zoned     = PACKED ARRAY [  1..maxzonedlength  ] OF char;
      num_error     = (num_ok, num_trunc, num_overflow, num_invalid);
.sp;.fo
The procedures below are available for converting VDN numbers
to the standard data types integer, real, decimal and zoned.
.sp
Meaning of the parameters:
.sp;.nf
        buf   : array or record containing the VDN number
        pos   : position of the VDN number in this array or record
        len   : length of the VDN number in digits (not in bytes!)
        frac  : number of decimal places or FLOAT
        dest  : destination variable of the conversion of the
                corresponding type
        dpos  : for strings, position in destination array
        dlen  : for strings, length of result
                for DECIMAL and ZONED, number of digits
        dfrac : for DECIMAL and ZONED, number of decimal places
        res   : response concerning success or error situations
.sp;.fo
The parameter BUF identifies the storage location of the VDN number.
The number of
.oc _/;positions
 (not bytes!) of the VDN number is indicated by LEN, the number of
decimal places is indicated by FRAC.  A FLOAT VDN number is
signalled by FRAC = -1 (use constant FLOAT_FRAC).
.sp
The parameter DEST
is the output parameter for the standard data types.
.sp
For the data types decimal and zoned, DEST is still to be described
by the total number of positions and the number of decimal places.
Decimal numbers and zoned numbers are to be supplied
.oc _/1;left-justified.
.sp
Each time a conversion procedure is called, the response
RES is to be queried which supplies information on whether the procedure
ran correctly or whether there were exceptional or error conditions
during the conversion.
.sp
PROCEDURE S40GSINT
.sp
Changes a VDN number to a 2-byte integer.
.sp
PROCEDURE S40GSUNS
.sp
Changes a VDN number to a 2-byte unsigned integer.
.sp
PROCEDURE S40GLINT
.sp
Changes a VDN number to a 4-byte integer.
.sp
PROCEDURE S40GLUNS
.sp
Changes a VDN number to a 4-byte unsigned integer um.
.sp
PROCEDURE S40GSREL
.sp
Changes a VDN number to a 4-byte real number.
.sp
PROCEDURE S40GLREL
.sp
Changes a VDN number to an 8-byte real number.
.sp
PROCEDURE S40GDEC
.sp
Changes a VDN number to a decimal number with a maximum length of 10 bytes.
The decimal number may have a maximum of 18 digits.
.sp
PROCEDURE S40GZONE
.sp
Changes a VDN number to a zoned number with a maximum length of 18 bytes.
A zoned number is generated with the COBOL standard zoned data
representation,
which also corresponds to the system/370 zoned data format.
.sp
PROCEDURE S40GBYTE
.sp
Edits a byte string to form a readable string representation.
The parameter TRUNCATED is set to TRUE if the length of the destination
string is not sufficient.
.sp 2
.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
      maxlongrealdigits  = 16;
 
TYPE
      zoned_type = (z_trailing_sign,
            z_leading_sign,
            z_sep_trailing_sign,
            z_sep_leading_sign);
 
 
(*------------------------------*) 
 
PROCEDURE
      s40check (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR res  : tsp00_NumError);
 
VAR
      i    : integer;
      nlen : integer;
 
BEGIN
res := num_ok;
nlen := pos + (len + 1) DIV 2;
WHILE (buf [nlen] = chr (0)) AND (nlen > 1) DO
    nlen := nlen - 1;
(*ENDWHILE*) 
FOR i := pos + 1 TO nlen DO
    IF  (ord (buf [i] ) MOD 16 > 9) OR
        (ord (buf [i] ) DIV 16 > 9)
    THEN
        res := num_invalid;
    (*ENDIF*) 
(*ENDFOR*) 
END; (* s40check *)
 
(*------------------------------*) 
 
PROCEDURE
      s40gsint (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Int2;
            VAR res  : tsp00_NumError);
 
VAR
      help : tsp00_Int4;
 
BEGIN
s40glint (buf, pos, len, help, res);
IF  (res = num_ok) OR (res = num_trunc)
THEN
    (* minint2 = (maxint2 + 1) * (- 1) *)
    IF    (help < (- csp_maxint2 - 1)) OR (help > csp_maxint2)
    THEN
        res := num_overflow
    ELSE
        dest := help;
    (*ENDIF*) 
(*ENDIF*) 
END; (* s40gsint *)
 
(*------------------------------*) 
 
PROCEDURE
      s40glint (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Int4;
            VAR res  : tsp00_NumError);
 
CONST
      is_undefined     = -1;
      minlint_exponent = 54;
      maxlint_exponent = 202;
 
VAR
      buflen      : integer;
      exp         : integer;
      i           : tsp00_Int4;
      p           : tsp00_Int4;
      digits      : integer;
      min_digit   : integer;
      significant : integer;
      xi          : integer;
      n           : tsp00_Number;
      x           : ARRAY [1..40 ] OF integer;
 
LABEL
      999;
 
BEGIN
res  := num_ok;
exp := ord (buf [ pos ] );
IF  exp = csp_zero_exp_value
THEN
    dest := 0
ELSE
    IF  (exp > 63) AND (exp < 193)
    THEN
        BEGIN
        dest := 0;
        res  := num_trunc
        END
    ELSE
        BEGIN
        dest := is_undefined;
        p    := pos + (len + 1) DIV 2;
        WHILE buf [p] = chr(0) DO
            p := p - 1;
        (*ENDWHILE*) 
        IF  exp < csp_zero_exp_value
        THEN (* negative number *)
            BEGIN
            IF  exp <= minlint_exponent
            THEN
                BEGIN (* number may be <= csp_minlint *)
                n := csp_null_number;
                FOR i := pos TO p DO
                    n [ i - pos + 1 ] := buf  [i]  ;
                (*ENDFOR*) 
                IF  n < csp_minlint
                THEN
                    BEGIN
                    res := num_overflow;
                    goto 999
                    END
                ELSE
                    IF  n = csp_minlint
                    THEN
                        BEGIN
                        (* PTS 1104701 E.Z. compilerproblem *)
                        dest := - csp_maxint4;
                        dest := dest - 1;
                        goto 999
                        END
                    (*ENDIF*) 
                (*ENDIF*) 
                END
            (*ENDIF*) 
            END
        ELSE
            IF  exp >= maxlint_exponent
            THEN
                BEGIN (* number may be > csp_maxlint *)
                n := csp_null_number;
                FOR i := pos TO p DO
                    n [ i - pos + 1 ] := buf  [i]  ;
                (*ENDFOR*) 
                IF  n > csp_maxlint
                THEN
                    BEGIN
                    res := num_overflow;
                    goto 999
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
        (*ENDIF*) 
        x [1]  := ord (buf [p] ) MOD 16;
        buflen := p - pos + 1;
        IF  x [1]  = 0
        THEN
            BEGIN (* last digit is 0 *)
            digits := 2 * buflen - 3;
            x [1]  := ord (buf [p] ) DIV 16;
            xi     := 2
            END
        ELSE
            BEGIN
            digits := 2 * buflen - 2;
            x [2]  := ord (buf [p] ) DIV 16;
            xi     := 3
            END;
        (*ENDIF*) 
        WHILE p > pos + 1 DO
            BEGIN
            p := p - 1;
            x [xi   ] := ord (buf [p] ) MOD 16;
            x [xi+1 ] := ord (buf [p] ) DIV 16;
            xi := xi + 2
            END;
        (*ENDWHILE*) 
        IF  exp < csp_zero_exp_value
        THEN (* negative number, construct complement *)
            BEGIN
            x [1]  := 10 - x [1] ;
            FOR i := 2 TO digits DO
                x [i]  := 9 - x [i] ;
            (*ENDFOR*) 
            significant := (256 - exp) - 192
            END
        ELSE
            significant := exp - 192;
        (*ENDIF*) 
        IF  digits > significant
        THEN
            BEGIN
            i := digits - significant;
            WHILE i >= 1 DO
                IF  x [i]  > 0
                THEN
                    BEGIN
                    res := num_trunc;
                    i   := 0 (* exit loop *)
                    END
                ELSE
                    i := i - 1;
                (*ENDIF*) 
            (*ENDWHILE*) 
            min_digit := digits - significant + 1
            END
        ELSE
            min_digit := 1;
        (*ENDIF*) 
        dest := x [digits] ;
        FOR i := digits - 1 DOWNTO min_digit DO
            dest := dest * 10 + x [i] ;
        (*ENDFOR*) 
        i := significant - digits;
        IF  i > 0
        THEN
            CASE i OF
                1 :
                    dest := dest * 10;
                2 :
                    dest := dest * 100;
                3 :
                    dest := dest * 1000;
                4 :
                    dest := dest * 10000;
                5 :
                    dest := dest * 100000;
                6 :
                    dest := dest * 1000000;
                7 :
                    dest := dest * 10000000;
                8 :
                    dest := dest * 100000000;
                9 :
                    dest := dest * 1000000000;
                OTHERWISE:
                    dest := dest * 1000000000;
                END;
            (*ENDCASE*) 
        (*ENDIF*) 
        IF  exp < csp_zero_exp_value
        THEN
            dest := - dest
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDIF*) 
999 : ;
END; (* s40glint *)
 
(*------------------------------*) 
 
PROCEDURE
      s40g4int (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            VAR dest : tsp00_Int4;
            VAR res  : tsp00_NumError);
 
CONST
      is_undefined     = -1;
      minlint_exponent = 54;
      maxlint_exponent = 202;
 
VAR
      buflen      : integer;
      exp         : integer;
      i           : tsp00_Int4;
      p           : tsp00_Int4;
      digits      : integer;
      min_digit   : integer;
      significant : integer;
      xi          : integer;
      n           : tsp00_Number;
      x           : ARRAY [1..40 ] OF integer;
      len         : integer;
 
LABEL
      999;
 
BEGIN
len := csp_resnum_deflen;
res  := num_ok;
exp := ord (buf [ pos ] );
IF  exp = csp_zero_exp_value
THEN
    dest := 0
ELSE
    IF  (exp > 63) AND (exp < 193)
    THEN
        BEGIN
        dest := 0;
        res  := num_trunc
        END
    ELSE
        BEGIN
        dest := is_undefined;
        p    := pos + (len + 1) DIV 2;
        WHILE buf [p] = chr(0) DO
            p := p - 1;
        (*ENDWHILE*) 
        IF  exp < csp_zero_exp_value
        THEN (* negative number *)
            BEGIN
            IF  exp <= minlint_exponent
            THEN
                BEGIN (* number may be <= csp_minlint *)
                n := csp_null_number;
                FOR i := pos TO p DO
                    n [ i - pos + 1 ] := buf  [i]  ;
                (*ENDFOR*) 
                IF  n < csp_minlint
                THEN
                    BEGIN
                    res := num_overflow;
                    goto 999
                    END
                ELSE
                    IF  n = csp_minlint
                    THEN
                        BEGIN
                        (* PTS 1104701 E.Z. compilerproblem *)
                        dest := - csp_maxint4;
                        dest := dest - 1;
                        goto 999
                        END
                    (*ENDIF*) 
                (*ENDIF*) 
                END
            (*ENDIF*) 
            END
        ELSE
            IF  exp >= maxlint_exponent
            THEN
                BEGIN (* number may be > csp_maxlint *)
                n := csp_null_number;
                FOR i := pos TO p DO
                    n [ i - pos + 1 ] := buf  [i]  ;
                (*ENDFOR*) 
                IF  n > csp_maxlint
                THEN
                    BEGIN
                    res := num_overflow;
                    goto 999
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
        (*ENDIF*) 
        x [1]  := ord (buf [p] ) MOD 16;
        buflen := p - pos + 1;
        IF  x [1]  = 0
        THEN
            BEGIN (* last digit is 0 *)
            digits := 2 * buflen - 3;
            x [1]  := ord (buf [p] ) DIV 16;
            xi     := 2
            END
        ELSE
            BEGIN
            digits := 2 * buflen - 2;
            x [2]  := ord (buf [p] ) DIV 16;
            xi     := 3
            END;
        (*ENDIF*) 
        WHILE p > pos + 1 DO
            BEGIN
            p := p - 1;
            x [xi   ] := ord (buf [p] ) MOD 16;
            x [xi+1 ] := ord (buf [p] ) DIV 16;
            xi := xi + 2
            END;
        (*ENDWHILE*) 
        IF  exp < csp_zero_exp_value
        THEN (* negative number, construct complement *)
            BEGIN
            x [1]  := 10 - x [1] ;
            FOR i := 2 TO digits DO
                x [i]  := 9 - x [i] ;
            (*ENDFOR*) 
            significant := (256 - exp) - 192
            END
        ELSE
            significant := exp - 192;
        (*ENDIF*) 
        IF  digits > significant
        THEN
            BEGIN
            i := digits - significant;
            WHILE i >= 1 DO
                IF  x [i]  > 0
                THEN
                    BEGIN
                    res := num_trunc;
                    i   := 0 (* exit loop *)
                    END
                ELSE
                    i := i - 1;
                (*ENDIF*) 
            (*ENDWHILE*) 
            min_digit := digits - significant + 1
            END
        ELSE
            min_digit := 1;
        (*ENDIF*) 
        dest := x [digits] ;
        FOR i := digits - 1 DOWNTO min_digit DO
            dest := dest * 10 + x [i] ;
        (*ENDFOR*) 
        i := significant - digits;
        IF  i > 0
        THEN
            CASE i OF
                1 :
                    dest := dest * 10;
                2 :
                    dest := dest * 100;
                3 :
                    dest := dest * 1000;
                4 :
                    dest := dest * 10000;
                5 :
                    dest := dest * 100000;
                6 :
                    dest := dest * 1000000;
                7 :
                    dest := dest * 10000000;
                8 :
                    dest := dest * 100000000;
                9 :
                    dest := dest * 1000000000;
                OTHERWISE:
                    dest := dest * 1000000000;
                END;
            (*ENDCASE*) 
        (*ENDIF*) 
        IF  exp < csp_zero_exp_value
        THEN
            dest := - dest
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDIF*) 
999 : ;
END; (* s40glint *)
 
(*------------------------------*) 
 
PROCEDURE
      s40g8int (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Longint;
            VAR res  : tsp00_NumError);
 
CONST
      is_undefined     = -1;
 
VAR
      buflen      : integer;
      exp         : integer;
      i           : integer;
      p           : tsp00_Int4;
      digits      : integer;
      min_digit   : integer;
      significant : integer;
      xi          : integer;
      x           : ARRAY [1..40 ] OF integer;
      help        : tsp00_Int4;
 
LABEL
      999;
 
BEGIN
IF  sizeof (dest) = INT4_MXSP00
THEN
    BEGIN
    help := dest;
    s40glint (buf, pos, len, help, res);
    goto 999
    END;
&ifdef BIT64
(*ENDIF*) 
res  := num_ok;
exp := ord (buf [ pos ] );
IF  exp = csp_zero_exp_value
THEN
    dest := 0
ELSE
    IF  (exp > 63) AND (exp < 193)
    THEN
        BEGIN
        dest := 0;
        res  := num_trunc
        END
    ELSE
        BEGIN
        dest := is_undefined;
        p    := pos + (len + 1) DIV 2;
        WHILE buf [p] = chr(0) DO
            p := p - 1;
        (*ENDWHILE*) 
        x [1]  := ord (buf [p] ) MOD 16;
        buflen := p - pos + 1;
        IF  x [1]  = 0
        THEN
            BEGIN (* last digit is 0 *)
            digits := 2 * buflen - 3;
            x [1]  := ord (buf [p] ) DIV 16;
            xi     := 2
            END
        ELSE
            BEGIN
            digits := 2 * buflen - 2;
            x [2]  := ord (buf [p] ) DIV 16;
            xi     := 3
            END;
        (*ENDIF*) 
        WHILE p > pos + 1 DO
            BEGIN
            p := p - 1;
            x [xi   ] := ord (buf [p] ) MOD 16;
            x [xi+1 ] := ord (buf [p] ) DIV 16;
            xi := xi + 2
            END;
        (*ENDWHILE*) 
        IF  exp < csp_zero_exp_value
        THEN (* negative number, construct complement *)
            BEGIN
            x [1]  := 10 - x [1] ;
            FOR i := 2 TO digits DO
                x [i]  := 9 - x [i] ;
            (*ENDFOR*) 
            significant := (256 - exp) - 192
            END
        ELSE
            significant := exp - 192;
        (*ENDIF*) 
        IF  digits > significant
        THEN
            BEGIN
            i := digits - significant;
            WHILE i >= 1 DO
                IF  x [i]  > 0
                THEN
                    BEGIN
                    res := num_trunc;
                    i   := 0 (* exit loop *)
                    END
                ELSE
                    i := i - 1;
                (*ENDIF*) 
            (*ENDWHILE*) 
            min_digit := digits - significant + 1
            END
        ELSE
            min_digit := 1;
        (*ENDIF*) 
        dest := x [digits] ;
        FOR i := digits - 1 DOWNTO min_digit DO
            dest := dest * 10 + x [i] ;
        (*ENDFOR*) 
        i := significant - digits;
        IF  i > 0
        THEN
            CASE i OF
                1 :
                    dest := dest * 10;
                2 :
                    dest := dest * 100;
                3 :
                    dest := dest * 1000;
                4 :
                    dest := dest * 10000;
                5 :
                    dest := dest * 100000;
                6 :
                    dest := dest * 1000000;
                7 :
                    dest := dest * 10000000;
                8 :
                    dest := dest * 100000000;
                9 :
                    dest := dest * 1000000000;
                10 :
                    dest := dest * 1000000000 * 10;
                11 :
                    dest := dest * 1000000000 * 100;
                12 :
                    dest := dest * 1000000000 * 1000;
                13 :
                    dest := dest * 1000000000 * 10000;
                14 :
                    dest := dest * 1000000000 * 100000;
                15 :
                    dest := dest * 1000000000 * 1000000;
                16 :
                    dest := dest * 1000000000 * 10000000;
                17 :
                    dest := dest * 1000000000 * 100000000;
                OTHERWISE
                    dest := dest * 1000000000 * 100000000;
                END;
            (*ENDCASE*) 
        (*ENDIF*) 
        IF  exp < csp_zero_exp_value
        THEN
            dest := - dest
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDIF*) 
&endif
999 : ;
END; (* s40g8int *)
 
(*------------------------------*) 
 
PROCEDURE
      s40gsuns (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Int2;
            VAR res  : tsp00_NumError);
 
CONST
      c_short = false;
 
VAR
      help   : tsp00_Int4;
      source : tsp00_Number;
      i      : integer;
 
BEGIN
source := csp_null_number;
FOR i := 1 TO (((len + 1) DIV 2) + 1) DO
    source   [ i ]   := buf [ pos + i - 1 ] ;
(*ENDFOR*) 
IF  source <= csp_maxsint
THEN
    BEGIN
    IF  source >= csp_minsuns
    THEN
        s40glint (buf, pos, len, help, res)
    ELSE
        res := num_overflow;
    (*ENDIF*) 
    END
ELSE
    sp40get_unsigned (buf, pos, len, help, c_short, res);
(*ENDIF*) 
IF  (res = num_ok) OR (res = num_trunc)
THEN
    (* minint2 = (maxint2 + 1) * (- 1) *)
    IF  (help < (- csp_maxint2 - 1)) OR (help > csp_maxint2)
    THEN
        res := num_overflow
    ELSE
        dest := help;
    (*ENDIF*) 
(*ENDIF*) 
END; (* s40gsuns *)
 
(*------------------------------*) 
 
PROCEDURE
      s40gluns (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Int4;
            VAR res  : tsp00_NumError);
 
CONST
      c_long = true;
 
VAR
      source : tsp00_Number;
      i      : integer;
 
BEGIN
source := csp_null_number;
FOR i := 1 TO ( ( (len + 1) DIV 2) + 1) DO
    source   [ i ]   := buf [ pos + i - 1 ] ;
(*ENDFOR*) 
IF  source <= csp_maxlint
THEN
    BEGIN
    IF  source >= csp_minluns
    THEN
        s40glint (buf, pos, len, dest, res)
    ELSE
        res := num_overflow;
    (*ENDIF*) 
    END
ELSE
    sp40get_unsigned (buf, pos, len, dest, c_long, res);
(*ENDIF*) 
END; (* s40gluns *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40get_unsigned (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Int4;
            long_val : boolean;
            VAR res  : tsp00_NumError);
 
VAR
      buflen : integer;
      i      : integer;
      n      : tsp00_Number;
      help   : tsp00_Number;
 
BEGIN
buflen := ( (len + 1) DIV 2) + 1;
help := csp_null_number;
(* save the relevant buf content, the following operations work on it *)
FOR i := 1 TO buflen DO
    help   [ i ]   := buf [ pos + i - 1 ] ;
(*ENDFOR*) 
n := help;
sp40unssub (n, long_val);
FOR i := 1 TO buflen DO
    buf [ pos + i - 1 ] := n [ i ]  ;
(*ENDFOR*) 
s40glint (buf, pos, len, dest, res);
IF  long_val
THEN
    BEGIN
    (* PTS 1104701 E.Z. compilerproblem *)
    dest := dest - csp_maxint4;
    dest := dest - 1;
    END
ELSE
    dest := dest - csp_maxint2 - 1;
(*ENDIF*) 
FOR i := 1 TO buflen DO
    buf [ pos + i - 1 ] := help   [ i ]  ;
(*ENDFOR*) 
END; (* sp40get_unsigned *)
 
(*------------------------------*) 
 
PROCEDURE
      s40gsrel (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Shortreal;
            VAR res  : tsp00_NumError);
 
VAR
      considered_digits : integer;
      buflen            : integer;
      digitcount        : integer;
      i                 : integer;
      hi_dig            : integer;
      lo_dig            : integer;
      exp               : integer;
      negativ           : boolean;
      n                 : tsp00_Number;
      help              : tsp00_Longreal;
 
BEGIN
considered_digits := maxlongrealdigits;
res := num_ok;
negativ := false;
exp := ord (buf [ pos ] );
help := 0.0;
IF  exp <> csp_zero_exp_value
THEN
    BEGIN
    buflen := ( (len + 1) DIV 2) + 1;
    FOR i := 1 TO buflen DO
        n   [ i ]   := buf [ pos + i - 1 ] ;
    (*ENDFOR*) 
    IF  exp < csp_zero_exp_value
    THEN
        BEGIN
        sp40complement (n, buflen);
        negativ := true;
        exp := 256 - exp;
        n   [ 1 ]   := chr (exp);
        END;
&   if $OS = UNIX
&   if $MACH = T35
    (*ENDIF*) 
    IF  (n < csp_minsrel) OR (n > csp_maxsrel)
    THEN
        res := num_overflow;
&   endif
&   endif
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  (exp <> csp_zero_exp_value) AND (res = num_ok)
THEN
    BEGIN
    digitcount := 0;
    FOR i := 1 TO buflen - 1 DO
        BEGIN
        digitcount := digitcount + 1;
        IF  digitcount <= considered_digits
        THEN
            BEGIN
            hi_dig := ord ( n [ 1 + i ] ) DIV 16;
            help := help * 10.0 + hi_dig;
            END
        ELSE
            IF  ord (n [ 1 + i ] ) DIV 16 <> 0
            THEN
                res := num_trunc;
            (*ENDIF*) 
        (*ENDIF*) 
        digitcount := digitcount + 1;
        IF  digitcount <= considered_digits
        THEN
            BEGIN
            lo_dig := ord ( n [ 1 + i ] ) MOD 16;
            help := help * 10.0 + lo_dig;
            END
        ELSE
            IF  ord (n [ 1 + i ] ) MOD 16 <> 0
            THEN
                res := num_trunc;
            (*ENDIF*) 
        (*ENDIF*) 
        END;
    (*ENDFOR*) 
    IF  digitcount >= considered_digits
    THEN
        digitcount := considered_digits;
    (* &if $OS = UNIX *)
    (* check always (e.g. WINDOWS/NT) because of ANSI tests *)
    (*ENDIF*) 
    IF  exp >= 192
    THEN
        i := exp - 192 - 1
    ELSE
        i := - (192 - exp + 1);
    (*ENDIF*) 
    WHILE digitcount < considered_digits DO
        BEGIN
        help := help * 10.0;
        digitcount := digitcount + 1;
        END;
    (*ENDWHILE*) 
    IF  (abs (i) > 38) OR
        ((i = -38) AND (help < 3.4e+15)) OR
        ((i = +38) AND (help > 3.4e+15))
        (* e+15 <=> considered_digits! *)
    THEN
        res := num_overflow;
    (* &endif *)
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  (exp <> csp_zero_exp_value) AND
    ((res = num_ok) OR (res = num_trunc))
THEN
    BEGIN
    (* help is now factor 10 ** digitcount too small or too big *)
    IF  exp > 192 + digitcount
    THEN
        BEGIN
        i := exp - 192 - digitcount;
        WHILE i >= 1 DO
            IF  i > 10
            THEN
                BEGIN
                help := help * 10.0E10;
                i := i - 11;
                END
            ELSE
                BEGIN
                help := help * 10;
                i := i - 1;
                END;
            (*ENDIF*) 
        (*ENDWHILE*) 
        END
    ELSE
        BEGIN
        i := 192 + digitcount - exp;
        WHILE i >= 1 DO
            IF  i > 10
            THEN
                BEGIN
                help := help / 1.0E10;
                i := i - 10;
                END
            ELSE
                BEGIN
                help := help / 10;
                i := i - 1;
                END;
            (*ENDIF*) 
        (*ENDWHILE*) 
        END;
    (*ENDIF*) 
    IF  negativ
    THEN
        help := - help;
    (*ENDIF*) 
    END;
(*ENDIF*) 
dest := help;
END; (* s40gsrel *)
 
(*------------------------------*) 
 
PROCEDURE
      s40glrel (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Longreal;
            VAR res  : tsp00_NumError);
 
VAR
      considered_digits : integer;
      buflen            : integer;
      digitcount        : integer;
      i                 : integer;
      hi_dig            : integer;
      lo_dig            : integer;
      exp               : integer;
      negativ           : boolean;
      n                 : tsp00_Number;
 
BEGIN
considered_digits := maxlongrealdigits;
res := num_ok;
negativ := false;
exp := ord (buf [ pos ] );
dest := 0.0;
IF  exp <> csp_zero_exp_value
THEN
    BEGIN
    buflen := ( (len + 1) DIV 2) + 1;
    FOR i := 1 TO buflen DO
        n   [ i ]   := buf [ pos + i - 1 ] ;
    (*ENDFOR*) 
    IF  exp < csp_zero_exp_value
    THEN
        BEGIN
        sp40complement (n, buflen);
        negativ := true;
        exp := 256 - exp;
        END;
    (*ENDIF*) 
    digitcount := 0;
    FOR i := 1 TO buflen - 1 DO
        BEGIN
        digitcount := digitcount + 1;
        IF  digitcount <= considered_digits
        THEN
            BEGIN
            hi_dig := ord ( n [ 1 + i ] ) DIV 16;
            dest := dest * 10.0 + hi_dig;
            END
        ELSE
            IF  ord (n [ 1 + i ] ) DIV 16 <> 0
            THEN
                res := num_trunc;
            (*ENDIF*) 
        (*ENDIF*) 
        digitcount := digitcount + 1;
        IF  digitcount <= considered_digits
        THEN
            BEGIN
            lo_dig := ord ( n [ 1 + i ] ) MOD 16;
            dest := dest * 10.0 + lo_dig;
            END
        ELSE
            IF  ord (n [ 1 + i ] ) MOD 16 <> 0
            THEN
                res := num_trunc;
            (*ENDIF*) 
        (*ENDIF*) 
        END;
    (*ENDFOR*) 
    IF  digitcount > considered_digits
    THEN
        digitcount := considered_digits;
    (* source is now factor 10 ** digitcount too small or too big *)
    (*ENDIF*) 
    IF  exp > 192 + digitcount
    THEN
        BEGIN
        i := exp - 192 - digitcount;
        WHILE i >= 1 DO
            IF  i > 10
            THEN
                BEGIN
                dest := dest * 10.0E10;
                i := i - 11;
                END
            ELSE
                BEGIN
                dest := dest * 10;
                i := i - 1;
                END;
            (*ENDIF*) 
        (*ENDWHILE*) 
        END
    ELSE
        BEGIN
        i := 192 + digitcount - exp;
        WHILE i >= 1 DO
            IF  i > 10
            THEN
                BEGIN
                dest := dest / 10.0E10;
                i := i - 11;
                END
            ELSE
                BEGIN
                dest := dest / 10;
                i := i - 1;
                END;
            (*ENDIF*) 
        (*ENDWHILE*) 
        END;
    (*ENDIF*) 
    IF  negativ
    THEN
        dest := - dest;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* s40glrel *)
 
(*------------------------------*) 
 
PROCEDURE
      s40gdec (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            VAR dest : tsp00_Decimal;
            dlen     : integer;
            dfrac    : integer;
            VAR res  : tsp00_NumError);
 
VAR
      declen     : integer;
      shiftlen   : integer;
      digitcount : integer;
      ni         : integer;
      i          : integer;
      hi_dig     : integer;
      lo_dig     : integer;
      exp        : integer;
      point_pos  : integer;
      more       : boolean;
      negativ    : boolean;
      n          : tsp00_Number;
 
BEGIN
res := num_ok;
negativ := false;
exp := ord ( buf [ pos ] );
declen := (dlen + 2) DIV 2;
IF  exp = csp_zero_exp_value
THEN
    BEGIN
    FOR i := 1 TO declen - 1 DO
        dest   [ i ]   := chr (0);
    (*ENDFOR*) 
    dest [ declen ] := chr (12);
    END
ELSE
    BEGIN
    ni := ( (len + 1) DIV 2 ) + 1;
    FOR i := 1 TO ni DO
        n   [ i ]   := buf [ pos + i - 1 ] ;
    (*ENDFOR*) 
    FOR i := ni + 1 TO mxsp_number DO
        n   [ i ]   := chr (0);
    (*ENDFOR*) 
    n   [ 1 ]   := chr (0);
    more := true;
    i := ni;
    WHILE (i > 1) AND more DO
        IF  n   [ i ]   <> chr (0)
        THEN
            more := false
        ELSE
            i := i - 1;
        (*ENDIF*) 
    (*ENDWHILE*) 
    ni := i;
    IF  exp < csp_zero_exp_value
    THEN
        BEGIN
        sp40complement (n, ni);
        negativ := true;
        exp := 256 - exp;
        END;
    (*ENDIF*) 
    lo_dig := ord (n   [ ni ]  ) MOD 16;
    IF  lo_dig = 0
    THEN
        digitcount := (ni - 1) * 2 - 1
    ELSE
        digitcount := (ni - 1) * 2;
    (*ENDIF*) 
    point_pos := exp - 192;
    IF  point_pos < (dlen - dfrac)
    THEN
        BEGIN
        IF  declen < DECIMAL_MXSP00
        THEN
            shiftlen := 1 + declen
        ELSE
            shiftlen := DECIMAL_MXSP00;
        (*ENDIF*) 
        sp40right_shift (n, shiftlen, - point_pos + (dlen - dfrac));
        digitcount := digitcount + (- point_pos + (dlen - dfrac));
        END;
    (*ENDIF*) 
    IF  point_pos > (dlen - dfrac)
    THEN
        res := num_overflow
    ELSE
        BEGIN
        IF  digitcount > dlen
        THEN
            res := num_trunc;
        (*ENDIF*) 
        IF  odd (dlen)
        THEN
            BEGIN
            FOR i := 1 TO declen DO
                dest   [ i ]   := n [ 1 + i ] ;
            (*ENDFOR*) 
            hi_dig := ord (dest [ declen ] ) DIV 16;
            IF  negativ
            THEN
                lo_dig := 13
            ELSE
                lo_dig := 12;
            (*ENDIF*) 
            dest [ declen ] := chr (16 * hi_dig + lo_dig);
            END
        ELSE
            BEGIN
            FOR i := 1 TO declen - 1 DO
                dest   [ i ]   := n [ 1 + i ] ;
            (*ENDFOR*) 
            sp40decsign (dest, declen, negativ);
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* s40gdec *)
 
(*------------------------------*) 
 
PROCEDURE
      s40gzone (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            frac     : integer;
            VAR dest : tsp00_Zoned;
            dlen     : integer;
            dfrac    : integer;
            VAR res  : tsp00_NumError);
 
VAR
      help    : tsp00_Decimal;
 
BEGIN
sp40prepdec (buf, pos, len, frac, dest, help, dlen, dfrac, res);
IF  (res = num_ok) OR (res = num_trunc)
THEN
    sp40dectozoned (help, dlen, dest, z_trailing_sign);
(*ENDIF*) 
END; (* s40gzone *)
 
(*------------------------------*) 
 
PROCEDURE
      s40glzon (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            frac     : integer;
            VAR dest : tsp00_Zoned;
            dlen     : integer;
            dfrac    : integer;
            VAR res  : tsp00_NumError);
 
VAR
      help    : tsp00_Decimal;
 
BEGIN
sp40prepdec (buf, pos, len, frac, dest, help, dlen, dfrac, res);
IF  (res = num_ok) OR (res = num_trunc)
THEN
    sp40dectozoned (help, dlen, dest, z_leading_sign);
(*ENDIF*) 
END; (* s40glzon *)
 
(*------------------------------*) 
 
PROCEDURE
      s40glszo (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            frac     : integer;
            VAR dest : tsp00_Zoned;
            dlen     : integer;
            dfrac    : integer;
            VAR res  : tsp00_NumError);
 
VAR
      help    : tsp00_Decimal;
 
BEGIN
dlen := dlen - 1;
sp40prepdec (buf, pos, len, frac, dest, help, dlen, dfrac, res);
IF  (res = num_ok) OR (res = num_trunc)
THEN
    sp40dectozoned (help, dlen, dest, z_sep_leading_sign);
(*ENDIF*) 
END; (* s40glszo *)
 
(*------------------------------*) 
 
PROCEDURE
      s40gtszo (
            VAR buf  : tsp00_MoveObj;
            pos      : tsp00_Int4;
            len      : integer;
            frac     : integer;
            VAR dest : tsp00_Zoned;
            dlen     : integer;
            dfrac    : integer;
            VAR res  : tsp00_NumError);
 
VAR
      help    : tsp00_Decimal;
 
BEGIN
dlen := dlen - 1;
sp40prepdec (buf, pos, len, frac, dest, help, dlen, dfrac, res);
IF  (res = num_ok) OR (res = num_trunc)
THEN
    sp40dectozoned (help, dlen, dest, z_sep_trailing_sign);
(*ENDIF*) 
END; (* s40gtszo *)
 
(*------------------------------*) 
 
PROCEDURE
      s40gbyte (
            VAR buf        : tsp00_MoveObj;
            pos            : tsp00_Int4;
            len            : integer;
            VAR dest       : tsp00_MoveObj;
            dpos           : tsp00_Int4;
            dlen           : integer;
            VAR truncated  : boolean);
 
VAR
      di     : integer;
      si     : integer;
      i      : integer;
      lo_dig : integer;
      hi_dig : integer;
 
BEGIN
truncated := false;
di := 0;
si := 0;
WHILE NOT truncated AND (si < len) DO
    IF  dlen < di + 2
    THEN
        truncated := true
    ELSE
        BEGIN
        si := si + 1;
        hi_dig := ord (buf [ pos + si - 1 ] ) DIV 16;
        lo_dig := ord (buf [ pos + si - 1 ] ) MOD 16;
        di := di + 1;
        IF  hi_dig <= 9
        THEN
            dest [ dpos + di - 1 ] := chr (hi_dig + ord ('0'))
        ELSE
            dest [ dpos + di - 1 ] := chr (hi_dig - 10 + ord ('A'));
        (*ENDIF*) 
        di := di  + 1;
        IF  lo_dig <= 9
        THEN
            dest [ dpos + di - 1 ] := chr (lo_dig + ord ('0'))
        ELSE
            dest [ dpos + di - 1 ] := chr (lo_dig - 10 + ord ('A'));
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDWHILE*) 
FOR i := di + 1 TO dlen DO
    dest [ dpos + i - 1 ] := '0';
(*ENDFOR*) 
END; (* s40gbyte *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40prepdec (
            VAR buf   : tsp00_MoveObj;
            pos       : tsp00_Int4;
            VAR len   : integer;
            VAR frac  : integer;
            VAR dest  : tsp00_Zoned;
            VAR help  : tsp00_Decimal;
            VAR dlen  : integer;
            VAR dfrac : integer;
            VAR res   : tsp00_NumError);
 
VAR
      i       : integer;
 
BEGIN
FOR i := 1 TO dlen DO
    dest   [ i ]   := ' ';
(*ENDFOR*) 
IF  len > csp_fixed
THEN
    len := csp_fixed;
(*ENDIF*) 
IF  frac > csp_fixed
THEN
    frac := csp_fixed;
(*ENDIF*) 
IF  dlen > csp_fixed
THEN
    dlen := csp_fixed;
(*ENDIF*) 
IF  dfrac > csp_fixed
THEN
    dfrac := csp_fixed;
(*ENDIF*) 
s40gdec (buf, pos, len,  help, dlen, dfrac, res);
END; (* sp40prepdec *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40dectozoned (
            VAR source   : tsp00_Decimal;
            VAR slen     : integer;
            VAR dest     : tsp00_Zoned;
            zoned_format : zoned_type);
 
VAR
      i             : integer;
      dig           : integer;
      dec_sign      : integer;
      base          : integer;
      negative_sign : integer;
      positive_sign : integer;
 
BEGIN
IF  ord (' ') = 32 (* Blank is hex 20 => ASCII *)
THEN
    BEGIN
    base := 48; (* hex 30, that is ASCII-0 (zero) *)
    negative_sign := 112; (* hex 70 for negative ASCII-Zoned numbers *)
    positive_sign := 48; (* hex 30 for positive ASCII-Zoned numbers *)
    END
ELSE
    BEGIN
    base := 240; (* hex F0, that is EBCDIC-0 (zero) *)
    negative_sign := 208; (* hex D0 for negative EBCDIC-Zoned numbers *)
    positive_sign := 192; (* hex C0 for positive EBCDIC-Zoned numbers *)
    END;
(*ENDIF*) 
IF  odd (slen)
THEN
    BEGIN
    FOR i := 1 TO slen DO
        BEGIN
        IF  odd (i)
        THEN
            dig := ord (source [ (i + 1) DIV 2 ] ) DIV 16
        ELSE
            dig := ord (source [ (i + 1) DIV 2 ] ) MOD 16;
        (*ENDIF*) 
        dest [ i ] := chr (base + dig);
        END;
    (*ENDFOR*) 
    END
ELSE
    BEGIN
    FOR i := 1 TO slen DO
        BEGIN
        IF  odd (i)
        THEN
            dig := ord (source [ (i DIV 2) + 1 ] ) MOD 16
        ELSE
            dig := ord (source [ (i DIV 2) + 1 ] ) DIV 16;
        (*ENDIF*) 
        dest [ i ] := chr (base + dig);
        END;
    (*ENDFOR*) 
    END;
(*ENDIF*) 
dec_sign := ord (source [ (slen DIV 2) + 1 ] ) MOD 16;
(* if negative then last halfbyte contains 13, else 12 *)
CASE zoned_format OF
    z_trailing_sign :
        BEGIN
        dig := ord (dest [ slen ] ) MOD 16;
        IF  dec_sign = 12
        THEN
            dest [ slen ] := chr (positive_sign + dig)
        ELSE
            dest [ slen ] := chr (negative_sign + dig);
        (*ENDIF*) 
        END;
    z_leading_sign :
        BEGIN
        dig := ord (dest   [ 1 ]  ) MOD 16;
        IF  dec_sign = 12
        THEN
            dest [ 1 ] := chr (positive_sign + dig)
        ELSE
            dest [ 1 ] := chr (negative_sign + dig);
        (*ENDIF*) 
        END;
    z_sep_trailing_sign :
        BEGIN
        slen := slen + 1;
        IF  dec_sign = 12
        THEN
            dest [ slen ] := '+'
        ELSE
            dest [ slen ] := '-';
        (*ENDIF*) 
        END;
    z_sep_leading_sign :
        BEGIN
        slen := slen + 1;
        FOR i := slen DOWNTO 2 DO
            dest [ i ] := dest [ i - 1 ] ;
        (*ENDFOR*) 
        IF  dec_sign = 12
        THEN
            dest [ 1 ] := '+'
        ELSE
            dest [ 1 ] := '-';
        (*ENDIF*) 
        END;
    END;
(*ENDCASE*) 
END; (* sp40dectozoned *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40complement (
            VAR n : tsp00_Number;
            actl  : integer);
 
VAR
      low   : integer;
      high  : integer;
      i     : integer;
      a     : integer;
 
BEGIN
WHILE (ord (n [ actl ] ) = 0) AND (actl > 1) DO
    actl := actl - 1;
(*ENDWHILE*) 
IF  actl > 1
THEN
    BEGIN
    a  := ord (n [ actl ] );
    IF  (a MOD 16) = 0
    THEN
        a := a - 7
    ELSE
        a := a - 1;
    (*ENDIF*) 
    n [ actl ] := chr (a);
    FOR i := 2  TO actl DO
        BEGIN
        high := 9 - ord (n   [ i ]  ) DIV 16;
        low := 9 - ord (n   [ i ]  ) MOD 16;
        n   [ i ]   := chr (high * 16 + low);
        END;
    (*ENDFOR*) 
    END;
(*ENDIF*) 
END; (* sp40complement *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40div10 (
            VAR source : tsp00_Number;
            actl       : integer);
 
VAR
      lo_dig : integer;
      hi_dig : integer;
      i      : integer;
 
BEGIN
FOR i := actl DOWNTO 1 DO
    BEGIN
    IF  i > 1
    THEN
        hi_dig := ord (source [ i - 1 ] ) MOD 16
    ELSE
        hi_dig := 0;
    (*ENDIF*) 
    lo_dig := ord (source   [ i ]  ) DIV 16;
    source   [ i ]   := chr (hi_dig * 16 + lo_dig);
    END;
(*ENDFOR*) 
END; (* sp40div10 *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40decsign (
            VAR dest : tsp00_Decimal;
            declen   : integer;
            negativ  : boolean);
 
VAR
      i      : integer;
      hi_dig : integer;
      lo_dig : integer;
      help   : tsp00_Decimal;
 
BEGIN
FOR i := 1 TO declen DO
    BEGIN
    IF  i > 1
    THEN
        hi_dig := ord (dest [ i - 1 ] ) MOD 16
    ELSE
        hi_dig := 0;
    (*ENDIF*) 
    IF  i < declen
    THEN
        lo_dig := ord (dest   [ i ]  ) DIV 16
    ELSE
        IF  negativ
        THEN
            lo_dig := 13
        ELSE
            lo_dig := 12;
        (*ENDIF*) 
    (*ENDIF*) 
    help   [ i ]   := chr (hi_dig * 16 + lo_dig);
    END;
(*ENDFOR*) 
FOR i := 1 TO declen DO
    dest   [ i ]   := help   [ i ]  ;
(*ENDFOR*) 
END; (* sp40decsign *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40right_shift (
            VAR source : tsp00_Number;
            actl       : integer;
            shift      : integer);
 
VAR
      i : integer;
 
BEGIN
IF  odd (shift)
THEN
    BEGIN
    shift := shift - 1;
    sp40div10 (source, actl);
    END;
(*ENDIF*) 
shift := shift DIV 2;
IF  shift > mxsp_number
THEN
    shift := mxsp_number;
(*ENDIF*) 
IF  shift > 0
THEN
    BEGIN
    FOR i := actl DOWNTO 1 + shift DO
        source   [ i ]   := source [ i - shift ] ;
    (*ENDFOR*) 
    FOR i := 1 TO shift DO
        source   [ i ]   := chr (0);
    (*ENDFOR*) 
    END;
(*ENDIF*) 
END; (* sp40right_shift *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40left_shift (
            VAR source : tsp00_Number;
            actl       : integer;
            shift      : integer);
 
VAR
      i : integer;
 
BEGIN
IF  odd (shift)
THEN
    BEGIN
    shift := shift - 1;
    sp40mul10 ( source, actl);
    END;
(*ENDIF*) 
shift := shift DIV 2;
IF  shift > mxsp_number
THEN
    shift := mxsp_number;
(*ENDIF*) 
IF  shift > 0
THEN
    BEGIN
    FOR i := 1 TO actl - shift DO
        source   [ i ]   := source [ i + shift ] ;
    (*ENDFOR*) 
    FOR i := actl - shift + 1 TO actl DO
        source   [ i ]   := chr (0);
    (*ENDFOR*) 
    END;
(*ENDIF*) 
END; (* sp40left_shift *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40unssub (VAR n : tsp00_Number;
            long_val : boolean);
 
VAR
      i           : integer;
      result_expo : integer;
      left_dig    : integer;
      right_dig   : integer;
      borrow      : integer;
      result_low  : integer;
      result_high : integer;
      left        : tsp00_Number;
      right       : tsp00_Number;
      result      : tsp00_Number;
      left_mod_16 : integer;
      right_mod_16 : integer;
 
BEGIN
IF  long_val
THEN
    right := csp_comlint
ELSE
    right := csp_comsint;
(*ENDIF*) 
left := n;
IF  left = right
THEN
    BEGIN
    (* Zero must have exponent csp_zero_exp_value, *)
    (* otherwise s40glint generates 'undefined' *)
    result_expo := csp_zero_exp_value;
    FOR i := 1 TO mxsp_number DO
        result [i] := chr (0);
    (*ENDFOR*) 
    END
ELSE
    BEGIN
    result_expo := ord (left [ 1 ] );
    left  [ 1 ] := chr (0);
    right [ 1 ] := chr (0);
    borrow := 0 ;
    FOR i := mxsp_number DOWNTO 1 DO
        BEGIN
        left_dig := ord (left   [ i ]  );
        right_dig := ord (right   [ i ]  );
        left_mod_16 := left_dig MOD 16;
        right_mod_16 := right_dig MOD 16;
        result_low := left_mod_16 - right_mod_16 - borrow;
        IF  result_low < 0
        THEN
            BEGIN
            result_low := result_low + 10;
            borrow := 1;
            END
        ELSE
            borrow := 0;
        (*ENDIF*) 
        result_high := left_dig DIV 16 - right_dig DIV 16 - borrow;
        IF  result_high < 0
        THEN
            BEGIN
            result_high := result_high + 10;
            borrow := 1
            END
        ELSE
            borrow := 0;
        (*ENDIF*) 
        result   [ i ]   := chr (result_high * 16 + result_low);
        END;
    (*ENDFOR*) 
    END;
(*ENDIF*) 
n := result;
n [ 1 ] := chr (result_expo);
END; (* sp40unssub *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40normalize (
            VAR result      : tsp00_Number;
            actl            : integer;
            VAR result_expo : integer);
 
VAR
      i        : integer;
      shift    : integer;
      more     : boolean;
 
BEGIN
IF  result   [ 2 ]   < chr (10)
THEN
    BEGIN
    shift := 0;
    i := 2;
    more := true;
    WHILE (i <= actl) AND more DO
        IF  result   [ i ]   = chr (0)
        THEN
            BEGIN
            shift := shift + 2;
            i := i + 1;
            END
        ELSE
            more := false;
        (*ENDIF*) 
    (*ENDWHILE*) 
    IF  (NOT more) AND (result   [ i ]   < chr (10))
    THEN
        shift := shift + 1;
    (*ENDIF*) 
    IF  more
    THEN
        result_expo := csp_zero_exp_value  (* result is zero *)
    ELSE
        BEGIN
        sp40left_shift (result, actl, shift);
        IF  result_expo >= csp_zero_exp_value
        THEN
            BEGIN
            result_expo := result_expo - shift;
            IF  result_expo < csp_zero_exp_value
            THEN
                BEGIN
                result_expo := csp_zero_exp_value;
                FOR i := 2 TO actl DO
                    result   [ i ]   := chr (0);
                (*ENDFOR*) 
                END
            (*ENDIF*) 
            END
        ELSE
            BEGIN
            result_expo := result_expo + shift;
            IF  result_expo > csp_zero_exp_value
            THEN
                BEGIN
                result_expo := csp_zero_exp_value;
                FOR i := 2 TO actl DO
                    result   [ i ]   := chr (0);
                (*ENDFOR*) 
                END
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* sp40normalize *)
 
(*------------------------------*) 
 
PROCEDURE
      sp40mul10 (
            VAR n : tsp00_Number;
            actl  : integer);
 
VAR
      i      : integer;
      hi_dig : integer;
      lo_dig : integer;
 
BEGIN
FOR i := 1 TO actl DO
    BEGIN
    hi_dig := ord (n   [ i ]  ) MOD 16;
    IF  i < actl
    THEN
        lo_dig := ord (n [ i + 1 ] ) DIV 16
    ELSE
        lo_dig := 0;
    (*ENDIF*) 
    n   [ i ]   := chr (hi_dig * 16 + lo_dig);
    END;
(*ENDFOR*) 
END; (* sp40mul10 *)
 
.CM *-END-* code ----------------------------------------
.SP 2 
***********************************************************
.PA 
