.CM  SCRIPT , Version - 1.1 , last edited by holger
.ad 8
.bm 8
.fm 4
.bt $Copyright (c) 2000-2005 SAP AG$$Page %$
.tm 12
.hm 6
.hs 3
.TT 1 $SQL$Project Distributed Database System$VSP41$
.tt 2 $$$
.TT 3 $$Conversions Into VDN-Numbers$2000-03-02$
***********************************************************
.nf
 
.nf
 
 .nf
 
    ========== licence begin  GPL
    Copyright (c) 2000-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  : PUT-Conversions
=========
.sp
Purpose : Conversions Into VDN-Numbers
.CM *-END-* purpose -------------------------------------
.sp
.cp 3
Define  :
 
        PROCEDURE
              s41psint (
                    VAR buf : tsp00_MoveObj;
                    pos     : tsp00_Int4;
                    len     : integer;
                    frac    : integer;
                    source  : tsp00_Int2;
                    VAR res : tsp00_NumError);
 
        PROCEDURE
              s41plint (
                    VAR buf : tsp00_MoveObj;
                    pos     : tsp00_Int4;
                    len     : integer;
                    frac    : integer;
                    source  : tsp00_Int4;
                    VAR res : tsp00_NumError);
 
        PROCEDURE
              s41p4int (
                    VAR buf : tsp00_MoveObj;
                    pos     : tsp00_Int4;
                    source  : tsp00_Int4;
                    VAR res : tsp00_NumError);
 
        PROCEDURE
              s41p8int (
                    VAR buf : tsp00_MoveObj;
                    pos     : tsp00_Int4;
                    len     : integer;
                    frac    : integer;
                    source  : tsp00_Longint;
                    VAR res : tsp00_NumError);
 
        PROCEDURE
              s41psuns (
                    VAR buf : tsp00_MoveObj;
                    pos     : tsp00_Int4;
                    len     : integer;
                    frac    : integer;
                    source  : tsp00_Int2;
                    VAR res : tsp00_NumError);
 
        PROCEDURE
              s41pluns (
                    VAR buf : tsp00_MoveObj;
                    pos     : tsp00_Int4;
                    len     : integer;
                    frac    : integer;
                    source  : tsp00_Int4;
                    VAR res : tsp00_NumError);
 
        PROCEDURE
              s41psrel (
                    VAR buf : tsp00_MoveObj;
                    pos     : tsp00_Int4;
                    len     : integer;
                    frac    : integer;
                    source  : tsp00_Shortreal;
                    VAR res : tsp00_NumError);
 
        PROCEDURE
              s41plrel (
                    VAR buf : tsp00_MoveObj;
                    pos     : tsp00_Int4;
                    len     : integer;
                    frac    : integer;
                    source  : tsp00_Longreal;
                    VAR res : tsp00_NumError);
 
        PROCEDURE
              s41pdec (
                    VAR buf    : tsp00_MoveObj;
                    pos        : tsp00_Int4;
                    len        : integer;
                    frac       : integer;
                    VAR source : tsp00_Decimal;
                    slen       : integer;
                    sfrac      : integer;
                    VAR res    : tsp00_NumError);
 
        PROCEDURE
              s41pzone (
                    VAR buf    : tsp00_MoveObj;
                    pos        : tsp00_Int4;
                    len        : integer;
                    frac       : integer;
                    VAR source : tsp00_Zoned;
                    slen       : integer;
                    sfrac      : integer;
                    VAR res    : tsp00_NumError);
 
        PROCEDURE
              s41pbyte (
                    VAR buf     : tsp00_MoveObj;
                    pos         : tsp00_Int4;
                    VAR len     : integer;
                    VAR source  : tsp00_MoveObj;
                    spos        : tsp00_Int4;
                    slen        : integer;
                    VAR invalid : boolean);
 
        PROCEDURE
              s41p1byte (
                    VAR buf     : tsp00_MoveObj;
                    pos         : tsp00_Int4;
                    VAR len     : integer;
                    VAR source  : tsp00_MoveObj;
                    spos        : tsp00_Int4;
                    slen        : integer;
                    VAR invalid : 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 : 2000-03-02
.sp
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Specification:
 
Possible conversions:
.sp;.nf
From SHORTINT   to VDN number  : S41PSINT
From LONGINT    to VDN number  : S41PLINT
From 8BYTE_INT  to VDN number  : S41P8INT
From 4BYTE_INT  to VDN number  : S41P4INT (to exact fixed(10,0))
From UNSIGNED*2 to VDN number  : S41PSUNS
From UNSIGNED*4 to VDN number  : S41PLUNS
From SHORTREAL  to VDN number  : S41PSREL
From LONGREAL   to VDN number  : S41PLREL
From DECIMAL    to VDN number  : S41PDEC
From ZONED      to VDN number  : S41PZONE
From STRING     to byte string : S41PBYTE
.sp;.fo
The following constant and type declarations apply:
.sp;.nf
CONST
      maxdeclength = 10;
      maxzonedlength = 20;
      float_frac = - 1;
 
 
      maxsint           = '\C5\32\76\70\00\00\00\00\00\00';
      minsint           = '\3B\67\23\20\00\00\00\00\00\00';
      maxlint           = '\CA\21\47\48\36\47\00\00\00\00';
      minlint           = '\36\78\52\51\63\52\00\00\00\00';
      comsuns           = '\C5\65\53\60\00\00\00\00\00\00';
      comsint           = '\C5\32\76\80\00\00\00\00\00\00';
      maxsuns           = '\C5\65\53\50\00\00\00\00\00\00';
      minsuns           = '\80\00\00\00\00\00\00\00\00\00';
      comluns           = '\CA\42\94\96\72\96\00\00\00\00';
      comlint           = '\CA\21\47\48\36\48\00\00\00\00';
      maxluns           = '\CA\42\94\96\72\95\00\00\00\00';
      minluns           = '\80\00\00\00\00\00\00\00\00\00';
 
TYPE
      int2 = (* 2 Byte Integer *);
      int4 = (* 4 Byte Integer *);
      shortreal = (* 4 Byte Real *);
      longreal = (* 8 Byte Real *);
      decimal = PACKED ARRAY [ 1..maxdeclength ] OF char;
      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  the standard
data types integer, real, decimal and zoned into VDN numbers.
.sp
Meaning of the parameters:
.sp;.nf
        buf    : array or record in which the VDN number is stored
        pos    : position at which the VDN number is to be stored
        len    : length of the VDN number is digits (not in bytes!)
        frac   : number of decimal places or FLOAT
        source : source variable of appropriate type
        spos   : for strings, position of the source string in source
                 array
        slen   : for strings, precise (!) length of the source string
                 for DECIMAL and ZONED, number of digits
        sfrac  : for DECIMAL and ZONED, number of decimal places
        res    : response concerning success or error situations
.sp;.fo
The parameter BUF identifies the record or array in which the
VDN number is to be stored.
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 SOURCE
is the input parameter for the
standard data types.
.sp
In the case of the data types decimal and zoned, SOURCE
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
After each call of a conversion procedure, 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 S41PSINT
.sp
Stores a 2-byte integer as a VDN number.
.sp
PROCEDURE S41PLINT
.sp
Stores a 4-byte integer as a VDN number.
.sp
PROCEDURE S41PSUNS
.sp
Stores a 2-byte unsigned integer as a VDN number.
.sp
PROCEDURE S41PLUNS
.sp
Stores a 4-byte unsigned integer as a VDN number.
.sp
PROCEDURE S41PSREL
.sp
Stores a 4-byte real number as a VDN number.
.sp
PROCEDURE S41PLREL
.sp
Stores an 8-byte real number as a VDN number.
.sp
PROCEDURE S41PDEC
.sp
Stores a decimal number with a maximum of 38 digits as a VDN number.
.sp
PROCEDURE S41PZONE
.sp
Stores a zoned number with a maximum of 38 digits as a VDN number.
For the representation of the zoned numbers, the /370 zoned data format,
the COBOL standard zoned data representation, the
COBOL zoned data with leading sign and COBOL zoned data with
trailing sign in separate position are valid.
.sp
PROCEDURE S41PBYTE
.sp
Stores a readable hexadecimal notation as a byte string.  If
the input string contains characters other than 0 .. 9 and A .. F or
a .. f, the parameter INVALID is set to TRUE.
.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    :
 
 
(*------------------------------*) 
 
PROCEDURE
      s41psint (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            len     : integer;
            frac    : integer;
            source  : tsp00_Int2;
            VAR res : tsp00_NumError);
 
VAR
      help : tsp00_Int4;
 
BEGIN
help := source;
s41plint (buf, pos, len, frac, help, res);
END; (* s41psint *)
 
(*------------------------------*) 
 
PROCEDURE
      s41plint (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            len     : integer;
            frac    : integer;
            source  : tsp00_Int4;
            VAR res : tsp00_NumError);
 
VAR
      is_hi          : boolean;
      is_negative    : boolean;
      do_complement  : boolean;
      digits         : integer;
      bufpos         : tsp00_Int4;
      i              : tsp00_Int4;
      curr_byte      : integer;
      curr_dig       : integer;
      hi             : tsp00_Int4;
      n              : tsp00_Number;
 
BEGIN
res := num_ok;
IF  source = 0
THEN
    BEGIN
    buf [ pos ] := csp_zero_exponent;
    FOR i := pos + 1 TO pos + ((len + 1) DIV 2) DO
        buf [ i ] := chr(0);
    (*ENDFOR*) 
    END
ELSE
    (* case source = minint4, then (- source) is too big *)
    IF  - (source + 1) = csp_maxint4
    THEN
        BEGIN
        n := csp_minlint;
        (* PTS 1125007 E.Z. *)
        FOR i := 1 TO ((len + 1) DIV 2) + 1 DO
            buf [ pos + i - 1 ] := n [i]
        (*ENDFOR*) 
        END
    ELSE
        BEGIN
        IF  source < 0
        THEN
            BEGIN
            is_negative   := true;
            do_complement := false;
            source        := - source
            END
        ELSE
            is_negative := false;
        (*ENDIF*) 
        IF  source < 10000
        THEN
            IF  source < 100
            THEN
                IF  source < 10
                THEN
                    BEGIN
                    digits := 1;
                    bufpos := pos + 1;
                    is_hi := true
                    END
                ELSE
                    BEGIN
                    digits := 2;
                    bufpos := pos + 1;
                    is_hi  := false
                    END
                (*ENDIF*) 
            ELSE
                IF  source < 1000
                THEN
                    BEGIN
                    digits := 3;
                    bufpos := pos + 2;
                    is_hi  := true
                    END
                ELSE
                    BEGIN
                    digits := 4;
                    bufpos := pos + 2;
                    is_hi  := false
                    END
                (*ENDIF*) 
            (*ENDIF*) 
        ELSE
            IF  source < 1000000
            THEN
                IF  source < 100000
                THEN
                    BEGIN
                    digits := 5;
                    bufpos := pos + 3;
                    is_hi  := true
                    END
                ELSE
                    BEGIN
                    digits := 6;
                    bufpos := pos + 3;
                    is_hi  := false
                    END
                (*ENDIF*) 
            ELSE
                IF  source < 100000000
                THEN
                    IF  source < 10000000
                    THEN
                        BEGIN
                        digits := 7;
                        bufpos := pos + 4;
                        is_hi  := true
                        END
                    ELSE
                        BEGIN
                        digits := 8;
                        bufpos := pos + 4;
                        is_hi  := false
                        END
                    (*ENDIF*) 
                ELSE
                    IF  source < 1000000000
                    THEN
                        BEGIN
                        digits := 9;
                        bufpos := pos + 5;
                        is_hi  := true
                        END
                    ELSE
                        BEGIN
                        digits := 10;
                        bufpos := pos + 5;
                        is_hi  := false
                        END;
                    (*ENDIF*) 
                (*ENDIF*) 
            (*ENDIF*) 
        (*ENDIF*) 
        IF  frac = csp_float_frac
        THEN
            BEGIN
            IF  digits > len
            THEN
                res := num_trunc
            (*ENDIF*) 
            END
        ELSE
            IF  digits > len - frac
            THEN
                res := num_overflow;
            (*ENDIF*) 
        (*ENDIF*) 
        IF  res <> num_overflow
        THEN
            BEGIN
            IF  is_negative
            THEN
                buf [pos ] := chr (64 - digits)
            ELSE
                buf [pos ] := chr (192 + digits);
            (*ENDIF*) 
            IF  res = num_trunc
            THEN
                BEGIN
                digits := len;
                IF  digits MOD 2 = 0
                THEN
                    BEGIN
                    bufpos := pos + digits DIV 2;
                    is_hi  := true
                    END
                ELSE
                    BEGIN
                    bufpos := pos + digits DIV 2 + 1;
                    is_hi  := false
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
            FOR i := bufpos + 1 TO pos + ((len + 1) DIV 2) DO
                buf [i]  := chr(0);
            (*ENDFOR*) 
            curr_byte := 0;
            FOR i := 1 TO digits DO
                BEGIN
                hi       := source DIV 10;
                curr_dig := source - hi * 10;
                IF  is_negative
                THEN
                    IF  do_complement
                    THEN
                        curr_dig := 9 - curr_dig
                    ELSE
                        IF  curr_dig > 0
                        THEN
                            BEGIN
                            do_complement := true;
                            curr_dig      := 10 - curr_dig
                            END;
                        (*ENDIF*) 
                    (*ENDIF*) 
                (*ENDIF*) 
                IF  is_hi
                THEN
                    BEGIN
                    is_hi         := false;
                    buf [bufpos ] := chr ((curr_dig * 16) + curr_byte);
                    bufpos        := bufpos - 1
                    END
                ELSE
                    BEGIN
                    is_hi     := true;
                    curr_byte := curr_dig
                    END;
                (*ENDIF*) 
                source := hi
                END;
            (*ENDFOR*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDIF*) 
END; (* s41plint *)
 
(*------------------------------*) 
 
PROCEDURE
      s41p4int (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            source  : tsp00_Int4;
            VAR res : tsp00_NumError);
 
VAR
      is_hi          : boolean;
      is_negative    : boolean;
      do_complement  : boolean;
      digits         : integer;
      bufpos         : tsp00_Int4;
      i              : tsp00_Int4;
      curr_byte      : integer;
      curr_dig       : integer;
      hi             : tsp00_Int4;
      n              : tsp00_Number;
 
BEGIN
res := num_ok;
IF  source = 0
THEN
    BEGIN
    buf [ pos ] := csp_zero_exponent;
    FOR i := pos + 1 TO pos + ((csp_resnum_deflen + 1) DIV 2) DO
        buf [ i ] := chr(0);
    (*ENDFOR*) 
    END
ELSE
    (* case source = minint4, then (- source) is too big *)
    IF  - (source + 1) = csp_maxint4
    THEN
        BEGIN
        n := csp_minlint;
        (* PTS 1125007 E.Z. *)
        FOR i := 1 TO ((csp_resnum_deflen + 1) DIV 2) + 1 DO
            buf [ pos + i - 1 ] := n [i]
        (*ENDFOR*) 
        END
    ELSE
        BEGIN
        IF  source < 0
        THEN
            BEGIN
            is_negative   := true;
            do_complement := false;
            source        := - source
            END
        ELSE
            is_negative := false;
        (*ENDIF*) 
        IF  source < 10000
        THEN
            IF  source < 100
            THEN
                IF  source < 10
                THEN
                    BEGIN
                    digits := 1;
                    bufpos := pos + 1;
                    is_hi := true
                    END
                ELSE
                    BEGIN
                    digits := 2;
                    bufpos := pos + 1;
                    is_hi  := false
                    END
                (*ENDIF*) 
            ELSE
                IF  source < 1000
                THEN
                    BEGIN
                    digits := 3;
                    bufpos := pos + 2;
                    is_hi  := true
                    END
                ELSE
                    BEGIN
                    digits := 4;
                    bufpos := pos + 2;
                    is_hi  := false
                    END
                (*ENDIF*) 
            (*ENDIF*) 
        ELSE
            IF  source < 1000000
            THEN
                IF  source < 100000
                THEN
                    BEGIN
                    digits := 5;
                    bufpos := pos + 3;
                    is_hi  := true
                    END
                ELSE
                    BEGIN
                    digits := 6;
                    bufpos := pos + 3;
                    is_hi  := false
                    END
                (*ENDIF*) 
            ELSE
                IF  source < 100000000
                THEN
                    IF  source < 10000000
                    THEN
                        BEGIN
                        digits := 7;
                        bufpos := pos + 4;
                        is_hi  := true
                        END
                    ELSE
                        BEGIN
                        digits := 8;
                        bufpos := pos + 4;
                        is_hi  := false
                        END
                    (*ENDIF*) 
                ELSE
                    IF  source < 1000000000
                    THEN
                        BEGIN
                        digits := 9;
                        bufpos := pos + 5;
                        is_hi  := true
                        END
                    ELSE
                        BEGIN
                        digits := 10;
                        bufpos := pos + 5;
                        is_hi  := false
                        END;
                    (*ENDIF*) 
                (*ENDIF*) 
            (*ENDIF*) 
        (*ENDIF*) 
        IF  digits > csp_resnum_deflen
        THEN
            res := num_overflow;
        (*ENDIF*) 
        IF  res <> num_overflow
        THEN
            BEGIN
            IF  is_negative
            THEN
                buf [pos ] := chr (64 - digits)
            ELSE
                buf [pos ] := chr (192 + digits);
            (*ENDIF*) 
            IF  res = num_trunc
            THEN
                BEGIN
                digits := csp_resnum_deflen;
                IF  digits MOD 2 = 0
                THEN
                    BEGIN
                    bufpos := pos + digits DIV 2;
                    is_hi  := true
                    END
                ELSE
                    BEGIN
                    bufpos := pos + digits DIV 2 + 1;
                    is_hi  := false
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
            FOR i := bufpos + 1 TO pos + ((csp_resnum_deflen + 1) DIV 2) DO
                buf [i]  := chr(0);
            (*ENDFOR*) 
            curr_byte := 0;
            FOR i := 1 TO digits DO
                BEGIN
                hi       := source DIV 10;
                curr_dig := source - hi * 10;
                IF  is_negative
                THEN
                    IF  do_complement
                    THEN
                        curr_dig := 9 - curr_dig
                    ELSE
                        IF  curr_dig > 0
                        THEN
                            BEGIN
                            do_complement := true;
                            curr_dig      := 10 - curr_dig
                            END;
                        (*ENDIF*) 
                    (*ENDIF*) 
                (*ENDIF*) 
                IF  is_hi
                THEN
                    BEGIN
                    is_hi         := false;
                    buf [bufpos ] := chr ((curr_dig * 16) + curr_byte);
                    bufpos        := bufpos - 1
                    END
                ELSE
                    BEGIN
                    is_hi     := true;
                    curr_byte := curr_dig
                    END;
                (*ENDIF*) 
                source := hi
                END;
            (*ENDFOR*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDIF*) 
END; (* s41plint *)
 
(*------------------------------*) 
 
PROCEDURE
      s41p8int (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            len     : integer;
            frac    : integer;
            source  : tsp00_Longint;
            VAR res : tsp00_NumError);
 
VAR
      is_hi          : boolean;
      is_negative    : boolean;
      do_complement  : boolean;
      digits         : integer;
      digitsDiv2     : integer;
      bufpos         : tsp00_Int4;
      i              : tsp00_Int4;
      curr_byte      : integer;
      curr_dig       : integer;
      hi             : tsp00_Longint;
      aux            : tsp00_Longint;
      help           : tsp00_Int4;
 
BEGIN
(* PTS 1105800 *)
&ifdef BIT64
IF  (source <= MAX_INT4_SP00) AND (source + 1 >= -MAX_INT4_SP00)
THEN
&   endif
    BEGIN
    help := source;
    s41plint (buf, pos, len, frac, help, res);
    END
&ifdef BIT64
ELSE
    BEGIN
    IF  source < 0
    THEN
        BEGIN
        is_negative   := true;
        do_complement := false;
        source        := - source
        END
    ELSE
        is_negative := false;
    (*ENDIF*) 
    aux    := source DIV 1000000000;
    digits := 9;
    WHILE aux > 0 DO
        BEGIN
        digits := digits + 1;
        aux    := aux DIV 10;
        END;
    (*ENDWHILE*) 
    is_hi  := digits MOD 2 <> 0;
    bufpos := pos + (digits + 1) DIV 2;
    res    := num_ok;
    IF  frac = csp_float_frac
    THEN
        BEGIN
        IF  digits > len
        THEN
            res := num_trunc
        (*ENDIF*) 
        END
    ELSE
        IF  digits > len - frac
        THEN
            res := num_overflow;
        (*ENDIF*) 
    (*ENDIF*) 
    IF  res <> num_overflow
    THEN
        BEGIN
        IF  is_negative
        THEN
            buf [pos ] := chr (64 - digits)
        ELSE
            buf [pos ] := chr (192 + digits);
        (*ENDIF*) 
        IF  res = num_trunc
        THEN
            BEGIN
            digits := len;
            IF  digits MOD 2 = 0
            THEN
                BEGIN
                bufpos := pos + digits DIV 2;
                is_hi  := true
                END
            ELSE
                BEGIN
                bufpos := pos + digits DIV 2 + 1;
                is_hi  := false
                END;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        FOR i := bufpos + 1 TO pos + ((len + 1) DIV 2) DO
            buf [i]  := chr(0);
        (*ENDFOR*) 
        curr_byte := 0;
        FOR i := 1 TO digits DO
            BEGIN
            hi       := source DIV 10;
            curr_dig := source - hi * 10;
            IF  is_negative
            THEN
                IF  do_complement
                THEN
                    curr_dig := 9 - curr_dig
                ELSE
                    IF  curr_dig > 0
                    THEN
                        BEGIN
                        do_complement := true;
                        curr_dig      := 10 - curr_dig
                        END;
                    (*ENDIF*) 
                (*ENDIF*) 
            (*ENDIF*) 
            IF  is_hi
            THEN
                BEGIN
                is_hi         := false;
                buf [bufpos ] := chr ((curr_dig * 16) + curr_byte);
                bufpos        := bufpos - 1
                END
            ELSE
                BEGIN
                is_hi     := true;
                curr_byte := curr_dig
                END;
            (*ENDIF*) 
            source := hi
            END;
        (*ENDFOR*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
&endif
END; (* s41p8int *)
 
(*------------------------------*) 
 
PROCEDURE
      s41psuns (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            len     : integer;
            frac    : integer;
            source  : tsp00_Int2;
            VAR res : tsp00_NumError);
 
CONST
      c_short = false;
 
VAR
      helpsource : tsp00_Int4;
 
BEGIN
helpsource := source;
IF  source >= 0
THEN
    s41plint (buf, pos, len, frac, helpsource, res)
ELSE
    sp41common_unsigned (buf, pos, len, frac, helpsource, c_short, res);
(*ENDIF*) 
END; (* s41psuns *)
 
(*------------------------------*) 
 
PROCEDURE
      s41pluns (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            len     : integer;
            frac    : integer;
            source  : tsp00_Int4;
            VAR res : tsp00_NumError);
 
CONST
      c_long = true;
 
BEGIN
IF  source >= 0
THEN
    s41plint (buf, pos, len, frac, source, res)
ELSE
    sp41common_unsigned (buf, pos, len, frac, source, c_long, res);
(*ENDIF*) 
END; (* s41pluns *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41common_unsigned (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            len     : integer;
            frac    : integer;
            source  : tsp00_Int4;
            long_val: boolean;
            VAR res : tsp00_NumError);
 
VAR
      dif    : tsp00_Int4;
      buflen : integer;
      i      : integer;
      n      : tsp00_Number;
 
BEGIN
(* source is negative, otherwise this procedure is not called.    *)
(* result can thus be calculated as sum of base max_signed + 1    *)
(* (constant in sp41unsadd) and (max-signed + 1) - abs (source).  *)
(* Example: an int1 of signed -1 equals (127+1) + (127+1)-1 = 255 *)
IF  long_val
THEN
    BEGIN
    dif := source + 1;
    dif := 2147483647 + dif;
    END
ELSE
    dif := 32768 + source;
(*ENDIF*) 
s41plint (buf, pos, len, frac, dif, res);
n := csp_null_number;
buflen := ( (len + 1) DIV 2) + 1;
FOR i := 1 TO buflen DO
    n  [i]  := buf [ pos + i - 1] ;
(*ENDFOR*) 
sp41unsadd (n, long_val);
FOR i := 1 TO buflen DO
    buf [ pos + i - 1 ] := n  [i] ;
(*ENDFOR*) 
END; (* sp41common_unsigned *)
 
(*------------------------------*) 
 
PROCEDURE
      s41psrel (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            len     : integer;
            frac    : integer;
            source  : tsp00_Shortreal;
            VAR res : tsp00_NumError);
 
CONST
      maxshortrealdigits = 8;
 
VAR
      help        : tsp00_Longreal;
      i           : integer;
      exp         : integer;
      intpartlen  : integer;
      fractionlen : integer;
      s41plrellen : integer;
      hi_dig      : integer;
      truncpos    : integer;
 
BEGIN
help := source;
IF  len < maxshortrealdigits
THEN
    s41plrellen := len
ELSE
    s41plrellen := maxshortrealdigits;
(*ENDIF*) 
s41plrel (buf, pos, s41plrellen, csp_float_frac, help, res);
IF  (res = num_trunc) AND (len >= maxshortrealdigits)
THEN
    res := num_ok;
(*ENDIF*) 
FOR i := pos + (((s41plrellen + 1) DIV 2) + 1)
      TO pos + (((len + 1) DIV 2) + 1) - 1 DO
    buf  [i]  := chr (0);
(*ENDFOR*) 
exp := ord (buf [ pos] );
IF  (frac <> csp_float_frac) AND (exp <> csp_zero_exp_value)
THEN
    BEGIN
    intpartlen := abs (exp - csp_zero_exp_value) - 64;
    IF  intpartlen > 0
    THEN
        BEGIN
        IF  intpartlen > (len - frac)
        THEN
            res := num_overflow
        ELSE
            fractionlen := s41plrellen - intpartlen;
        (*ENDIF*) 
        END
    ELSE
        fractionlen := abs (intpartlen);
    (*ENDIF*) 
    IF  ((res = num_ok) OR (res = num_trunc)) AND (fractionlen > frac)
    THEN
        BEGIN
        truncpos := ( (intpartlen + frac + 1) DIV 2) + 1;
        IF  truncpos <= 0
        THEN
            BEGIN
            truncpos := 1;
            buf [pos] := csp_zero_exponent
            END
        ELSE
            IF  odd (intpartlen + frac)
            THEN
                BEGIN
                IF  ord (buf [ pos + truncpos - 1] ) MOD 16 <> 0
                THEN
                    res := num_trunc;
                (*ENDIF*) 
                hi_dig := ord (buf [ pos + truncpos - 1] ) DIV 16;
                buf [ pos + truncpos - 1 ] := chr (hi_dig * 16);
                END;
            (*ENDIF*) 
        (*ENDIF*) 
        FOR i := pos + truncpos TO pos + (((len + 1) DIV 2) + 1) - 1 DO
            BEGIN
            IF  buf [i] <> chr (0)
            THEN
                res := num_trunc;
            (*ENDIF*) 
            buf [i] := chr (0);
            END;
        (*ENDFOR*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* s41psrel *)
 
(*------------------------------*) 
 
PROCEDURE
      s41plrel (
            VAR buf : tsp00_MoveObj;
            pos     : tsp00_Int4;
            len     : integer;
            frac    : integer;
            source  : tsp00_Longreal;
            VAR res : tsp00_NumError);
 
CONST
      maxlongrealdigits = 16;
      minlongreal       = 5.0E-16;
 
VAR
      n           : tsp00_Number;
      buflen      : integer;
      digitcount  : integer;
      lo_dig      : integer;
      hi_dig      : integer;
      ni          : integer;
      exp         : integer;
      intpartlen  : integer;
      fracpartlen : integer;
      limit       : integer;
      negative    : boolean;
      all_zero    : boolean;
      roundval    : tsp00_Longreal;
      i           : integer;
      float_underflow : boolean;
      abs_source  : tsp00_Longreal;
 
BEGIN
float_underflow := false;
res := num_ok;
negative := false;
fracpartlen := 0;
IF  (source >= 1.0) OR (source <= -1.0)
THEN
    intpartlen := 1
ELSE
    intpartlen := 0;
(*ENDIF*) 
ni := 1;
IF  (source > -1E-64) AND (source < +1E-64)
THEN
    exp := csp_zero_exp_value
ELSE
    BEGIN
    abs_source := abs (source);
    IF  (abs_source > 9.99999999999999999E+62)
        OR
        (abs_source < 1.0E-64)
    THEN
        res := num_overflow
    ELSE
        BEGIN
        IF  source < 0.0
        THEN
            BEGIN
            exp := 63;
            negative := true;
            source := - source;
            END
        ELSE
            exp := 193;
        (*ENDIF*) 
        WHILE source <= 9.9999999999999E-11 DO
            BEGIN
            source := source * 1.0E10;
            IF  (NOT negative) AND (exp - 10 >= 129)
            THEN
                BEGIN
                exp := exp - 10;
                fracpartlen := fracpartlen + 10;
                END
            ELSE
                IF  negative AND (exp + 10 <= 127)
                THEN
                    BEGIN
                    exp := exp + 10;
                    fracpartlen := fracpartlen + 10;
                    END
                ELSE
                    exp := csp_zero_exp_value;
                (*ENDIF*) 
            (*ENDIF*) 
            END;
        (*ENDWHILE*) 
        WHILE source <= 9.9999999999999E-01 DO
            BEGIN
            source := source * 10.0;
            IF  (NOT negative) AND (exp > 129)
            THEN
                BEGIN
                exp := exp - 1;
                fracpartlen := fracpartlen + 1;
                END
            ELSE
                IF  negative AND (exp < 127)
                THEN
                    BEGIN
                    exp := exp + 1;
                    fracpartlen := fracpartlen + 1;
                    END
                ELSE
                    exp := csp_zero_exp_value;
                (*ENDIF*) 
            (*ENDIF*) 
            END;
        (*ENDWHILE*) 
        source := source + minlongreal;
        WHILE source >= 1.0E10 DO
            BEGIN
            source := source / 1.0E10;
            IF  (NOT negative) AND (exp + 10 <= 255)
            THEN
                BEGIN
                exp := exp + 10;
                intpartlen := intpartlen + 10;
                END
            ELSE
                IF  negative AND (exp - 10 >= 1)
                THEN
                    BEGIN
                    exp := exp - 10;
                    intpartlen := intpartlen + 10;
                    END
                ELSE
                    res := num_overflow;
                (*ENDIF*) 
            (*ENDIF*) 
            END;
        (*ENDWHILE*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  (exp <> csp_zero_exp_value) AND (res = num_ok)
THEN
    BEGIN
    WHILE source >= 10.0 DO
        BEGIN
        source := source / 10.0;
        IF  (NOT negative) AND (exp < 255)
        THEN
            BEGIN
            exp := exp + 1;
            intpartlen := intpartlen + 1;
            END
        ELSE
            IF  negative AND (exp > 1)
            THEN
                BEGIN
                exp := exp - 1;
                intpartlen := intpartlen + 1;
                END
            ELSE
                res := num_overflow;
            (*ENDIF*) 
        (*ENDIF*) 
        END;
    (*ENDWHILE*) 
    IF  frac <> csp_float_frac
    THEN
        BEGIN
        IF  negative
            AND ( (64 - exp) > (len - frac))
        THEN
            res := num_overflow;
        (*ENDIF*) 
        IF  NOT negative
            AND ( (exp - 192) > (len - frac))
        THEN
            res := num_overflow;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  (exp <> csp_zero_exp_value) AND (res = num_ok)
THEN
    BEGIN
    IF  frac = csp_float_frac
    THEN
        limit := len
    ELSE
        IF  intpartlen > 0
        THEN
            limit := intpartlen + frac
        ELSE
            limit := frac - fracpartlen + 1;
        (*ENDIF*) 
    (*ENDIF*) 
    IF  limit < 0
    THEN
        exp := csp_zero_exp_value;
    (*ENDIF*) 
    CASE limit OF
        0 :
            roundval := 5.0E00;
        1 :
            roundval := 5.0E-1;
        2 :
            roundval := 5.0E-2;
        3 :
            roundval := 5.0E-3;
        4 :
            roundval := 5.0E-4;
        5 :
            roundval := 5.0E-5;
        6 :
            roundval := 5.0E-6;
        7 :
            roundval := 5.0E-7;
        8 :
            roundval := 5.0E-8;
        9 :
            roundval := 5.0E-9;
        10 :
            roundval := 5.0E-10;
        11 :
            roundval := 5.0E-11;
        12 :
            roundval := 5.0E-12;
        13 :
            roundval := 5.0E-13;
        14 :
            roundval := 5.0E-14;
        15 :
            roundval := 5.0E-15;
        OTHERWISE
            BEGIN
            float_underflow := true;
            (* 19.4.94 : this is the maximum precision of a real *)
            (* roundval := 5.0E-16; dosn't work for 0.81E+02*)
            roundval := 5.0E-15;
            END;
        END;
    (*ENDCASE*) 
    IF  NOT float_underflow
    THEN
        source := source + roundval;
    (*ENDIF*) 
    IF  source >= 10.0
    THEN
        BEGIN
        source := source / 10.0;
        IF   limit = 0
        THEN
            limit := 1;
        (*ENDIF*) 
        IF  (NOT negative) AND (exp < 255)
        THEN
            BEGIN
            exp := exp + 1;
            intpartlen := intpartlen + 1;
            END
        ELSE
            IF  negative AND (exp > 1)
            THEN
                BEGIN
                exp := exp - 1;
                intpartlen := intpartlen + 1;
                END
            ELSE
                res := num_overflow;
            (*ENDIF*) 
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  (exp <> csp_zero_exp_value) AND (res = num_ok)
THEN
    BEGIN
    (* now 1.0 <= source < 10.0 *)
    digitcount := 0;
    WHILE (digitcount < limit) AND
          (digitcount < maxlongrealdigits) DO
        BEGIN
        digitcount := digitcount + 1;
        IF  (digitcount <= limit) AND
            (digitcount <= maxlongrealdigits)
        THEN
            BEGIN
            hi_dig := trunc (source);
            source := source - hi_dig;
            IF  float_underflow
            THEN
                BEGIN
                source := source + roundval;
                IF  source > 1.0
                THEN
                    BEGIN
                    source := source - roundval;
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
            source := source * 10
            END
        ELSE
            hi_dig := 0;
        (*ENDIF*) 
        digitcount := digitcount + 1;
        IF  (digitcount <= limit) AND
            (digitcount <= maxlongrealdigits)
        THEN
            BEGIN
            lo_dig := trunc (source);
            source := source - lo_dig;
            IF  float_underflow
            THEN
                BEGIN
                float_underflow := false;
                IF  lo_dig >= 10
                THEN
                    BEGIN
                    lo_dig := 0;
                    hi_dig := hi_dig +1;
                    END
                (*ENDIF*) 
                END;
            (*ENDIF*) 
            source := source * 10;
            END
        ELSE
            lo_dig := 0;
        (*ENDIF*) 
        IF  digitcount = maxlongrealdigits
        THEN
            (* maximum guaranteed precision is 15! Ma 15.04.1997 *)
            IF  odd (maxlongrealdigits)
            THEN
                hi_dig := 0
            ELSE
                lo_dig := 0;
            (*ENDIF*) 
        (*ENDIF*) 
        ni := ni + 1;
        n [ ni ] := chr (hi_dig * 16 + lo_dig);
        END;
    (*ENDWHILE*) 
    IF  len < maxlongrealdigits
    THEN
        IF  (source < 4.0) (* original value has been rounded *)
            OR (source >= 6.1) (* original value has been truncated *)
        THEN
            BEGIN
            (* writeln ('vsp41 source remainder ', source); *)
            res := num_trunc;
            END;
        (*ENDIF*) 
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  (res = num_ok) OR (res = num_trunc)
THEN
    BEGIN
    IF  negative
    THEN
        sp41complement (n, ni);
    (*ENDIF*) 
    IF  exp = 0
    THEN
        res := num_overflow
    ELSE
        BEGIN
        n [1] := chr (exp);
        buflen := ( (len + 1) DIV 2) + 1;
        all_zero := true;
        FOR i := 2 TO ni DO
            IF  n [i] <> chr (0)
            THEN
                all_zero := false;
            (*ENDIF*) 
        (*ENDFOR*) 
        FOR i := ni + 1 TO buflen DO
            n [i] := chr (0);
        (*ENDFOR*) 
        FOR i := 1 TO buflen DO
            buf [ pos + i - 1 ] := n  [i] ;
        (*ENDFOR*) 
        IF  all_zero
        THEN
            buf [ pos ] := csp_zero_exponent
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* s41plrel *)
 
(*------------------------------*) 
 
PROCEDURE
      s41pdec (
            VAR buf    : tsp00_MoveObj;
            pos        : tsp00_Int4;
            len        : integer;
            frac       : integer;
            VAR source : tsp00_Decimal;
            slen       : integer;
            sfrac      : integer;
            VAR res    : tsp00_NumError);
 
VAR
      i           : integer;
      ni          : integer;
      buflen      : integer;
      lo_dig      : integer;
      hi_dig      : integer;
      exp         : integer;
      dummy       : integer;
      bytelen     : integer;
      fracpartlen : integer;
      invalid     : boolean;
      negative    : boolean;
      skip        : boolean;
      n           : tsp00_Number;
 
BEGIN
res := num_ok;
IF  sfrac = csp_float_frac
THEN
    sfrac := 0;
(*ENDIF*) 
IF  frac = csp_float_frac
THEN
    fracpartlen := 0
ELSE
    BEGIN
    fracpartlen := frac;
    IF  sfrac > fracpartlen
    THEN
        res := num_trunc;
    (*ENDIF*) 
    END;
(*ENDIF*) 
negative := false;
invalid := false;
n := csp_null_number;
IF  (slen - sfrac) > 0
THEN
    skip := true
ELSE
    skip := false;
(*ENDIF*) 
IF  NOT odd (slen) (* not byte-aligned because of sign *)
THEN
    slen := slen + 1;
(*ENDIF*) 
bytelen := (slen + 2) DIV 2;
ni := 0;
FOR i := 1 TO (bytelen - 1) DO
    BEGIN
    IF  source  [i]  <> chr (0)
    THEN
        skip := false;
    (*ENDIF*) 
    IF  NOT skip
    THEN
        BEGIN
        IF  ni < sizeof (n)
        THEN
            BEGIN
            ni     := ni + 1;
            n [ni] := source [i]
            END
        ELSE
            res := num_trunc
        (*ENDIF*) 
        END
    ELSE
        slen := slen - 2;
    (*ENDIF*) 
    END;
(*ENDFOR*) 
exp := ord (source [bytelen]);
hi_dig   := exp DIV 16;
lo_dig   := exp MOD 16;
negative := (lo_dig = 13) OR (lo_dig = 11);
IF  ni < sizeof (n)
THEN
    BEGIN
    ni    := ni + 1;
    n[ni] := chr (hi_dig * 16);
    END
ELSE
    res := num_trunc;
(*ENDIF*) 
FOR i := 1 TO ni DO
    BEGIN
    hi_dig := ord (n  [i] ) DIV 16;
    lo_dig := ord (n  [i] ) MOD 16;
    IF  (hi_dig > 9) OR (lo_dig > 9)
    THEN
        invalid := true;
    (*ENDIF*) 
    END;
(*ENDFOR*) 
IF  invalid
THEN
    res := num_invalid
ELSE
    BEGIN
    IF  n = csp_null_number
    THEN
        BEGIN
        exp := csp_zero_exp_value;
        ni := 9;
        END
    ELSE
        BEGIN
        IF  ord (n  [1] ) DIV 16 = 0
        THEN
            BEGIN
            sp41mul10 (n, ni);
            ni := ni - 1;
            slen := slen - 1;
            END;
        (*ENDIF*) 
        IF  negative
        THEN
            exp := 64 - (slen - sfrac)
        ELSE
            exp := 192 + (slen - sfrac);
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    FOR i := ni DOWNTO 1 DO
        n [ i + 1 ] := n  [i] ;
    (*ENDFOR*) 
    n  [1]  := chr (0);
    ni := ni + 1;
    IF  n  [2]  < chr (10)
    THEN
        IF  (slen - sfrac) = 0
        THEN
            sp41normalize (n, ni, exp)
        ELSE
            sp41normalize (n, ni, dummy);
        (*ENDIF*) 
    (*ENDIF*) 
    IF  negative
    THEN
        BEGIN
        IF  (64 - exp) > (len - fracpartlen)
        THEN
            res := num_overflow
        (*ENDIF*) 
        END
    ELSE
        IF  (exp - 192) > (len - fracpartlen)
        THEN
            res := num_overflow ;
        (*ENDIF*) 
    (*ENDIF*) 
    IF  exp = 0
    THEN
        res := num_overflow;
    (*ENDIF*) 
    IF  res <> num_overflow
    THEN
        BEGIN
        n  [1]  := chr (exp);
        IF  negative
        THEN
            sp41complement (n, ni);
        (*ENDIF*) 
        buflen := ( (len + 1) DIV 2 ) + 1;
        IF  odd (len)
        THEN
            BEGIN
            hi_dig := ord (n [ buflen] ) DIV 16;
            n [ buflen ] := chr (hi_dig * 16);
            END;
        (*ENDIF*) 
        FOR i := 1 TO buflen DO
            buf [ pos + i - 1 ] := n  [i] ;
        (*ENDFOR*) 
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* s41pdec *)
 
(*------------------------------*) 
 
PROCEDURE
      s41pzone (
            VAR buf    : tsp00_MoveObj;
            pos        : tsp00_Int4;
            len        : integer;
            frac       : integer;
            VAR source : tsp00_Zoned;
            slen       : integer;
            sfrac      : integer;
            VAR res    : tsp00_NumError);
 
VAR
      helpzoned   : tsp00_Zoned;
      helpdecimal : tsp00_Decimal;
 
BEGIN
sp41extzonedtozoned (source, slen, helpzoned, res);
IF  res = num_ok
THEN
    sp41zonedtodec (helpzoned, slen, helpdecimal, res);
(*ENDIF*) 
IF  res = num_ok
THEN
    s41pdec (buf, pos, len, frac, helpdecimal, slen, sfrac, res);
(*ENDIF*) 
END; (* s41pzone *)
 
(*------------------------------*) 
 
PROCEDURE
      s41pbyte (
            VAR buf     : tsp00_MoveObj;
            pos         : tsp00_Int4;
            VAR len     : integer;
            VAR source  : tsp00_MoveObj;
            spos        : tsp00_Int4;
            slen        : integer;
            VAR invalid : boolean);
 
VAR
      limit  : tsp00_Int4;
      hi_dig : integer;
      lo_dig : integer;
      hipos  : boolean;
 
BEGIN
invalid := false;
limit := spos + slen - 1;
hipos := true;
len := 0;
WHILE NOT invalid AND (spos <= limit) DO
    BEGIN
    CASE source [ spos ] OF
        '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' :
            lo_dig := ord (source [ spos] ) - ord ('0');
        'A', 'B', 'C', 'D', 'E', 'F' :
            lo_dig := ord (source [ spos] ) - ord ('A') + 10;
        'a', 'b', 'c', 'd', 'e', 'f' :
            lo_dig := ord (source [ spos] ) - ord ('a') + 10;
        OTHERWISE:
            invalid := true;
        END;
    (*ENDCASE*) 
    hipos := NOT (hipos);
    IF  hipos AND NOT invalid
    THEN
        BEGIN
        len := len + 1;
        buf [ pos + len - 1 ] := chr (hi_dig * 16 + lo_dig);
        END
    ELSE
        hi_dig := lo_dig;
    (*ENDIF*) 
    spos := spos + 1;
    END;
(*ENDWHILE*) 
IF  NOT invalid AND NOT hipos
THEN
    invalid := true;
(*ENDIF*) 
END; (* s41pbyte *)
 
(*------------------------------*) 
 
PROCEDURE
      s41p1byte (
            VAR buf     : tsp00_MoveObj;
            pos         : tsp00_Int4;
            VAR len     : integer;
            VAR source  : tsp00_MoveObj;
            spos        : tsp00_Int4;
            slen        : integer;
            VAR invalid : boolean);
 
BEGIN
s41pbyte (buf, pos, len, source, spos, slen, invalid);
END; (* s41p1byte *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41extzonedtozoned (
            VAR source : tsp00_Zoned;
            VAR slen   : integer;
            VAR dest   : tsp00_Zoned;
            VAR res    : tsp00_NumError);
 
CONST
      csp_ascii_blank  = 32;
      csp_ebcdic_blank = 64;
      ascii_plus       = 43;
      ascii_minus      = 45;
      ebcdic_plus      = 78;
      ebcdic_minus     = 96;
      ascii_nibble     =  3;
      ebcdic_nibble    = 15;
 
TYPE
      zoned_type = (
            z_no_separate_sign,
            z_sep_trailing_plus,
            z_sep_trailing_minus,
            z_sep_leading_plus,
            z_sep_leading_minus);
 
VAR
      i            : integer;
      zoned_plus   : integer;
      zoned_minus  : integer;
      zoned_dig    : integer;
      zoned_flag   : integer;
      zoned_format : zoned_type;
      f_nibble     : integer;
 
BEGIN
IF  ord (' ') = csp_ascii_blank
THEN
    BEGIN
    zoned_plus := 48;
    zoned_minus := 112;
    f_nibble := ascii_nibble;
    END
ELSE
    BEGIN
    zoned_plus := 192;
    zoned_minus := 208;
    f_nibble := ebcdic_nibble;
    END;
(*ENDIF*) 
res := num_ok;
dest := source;
IF  slen = ZONED_MXSP00
THEN
    IF  (dest [ slen ] <> chr (csp_ebcdic_blank)) AND
        (dest [ slen ] <> chr (csp_ascii_blank))
    THEN
        res := num_invalid
    ELSE
        slen := slen - 1;
    (*ENDIF*) 
(*ENDIF*) 
IF  res = num_ok
THEN
    IF  (dest [ slen ] = chr (ebcdic_plus)) OR
        (dest [ slen ] = chr (csp_ebcdic_blank)) OR
        (dest [ slen ] = chr (csp_ascii_blank)) OR
        (dest [ slen ] = chr (ascii_plus))
    THEN
        zoned_format := z_sep_trailing_plus
    ELSE
        IF  (dest [ slen ] = chr (ebcdic_minus)) OR
            (dest [ slen ] = chr (ascii_minus))
        THEN
            zoned_format := z_sep_trailing_minus
        ELSE
            IF  (dest  [1]  = chr (ebcdic_plus)) OR
                (dest  [1]  = chr (csp_ebcdic_blank)) OR
                (dest  [1]  = chr (csp_ascii_blank)) OR
                (dest  [1]  = chr (ascii_plus))
            THEN
                zoned_format := z_sep_leading_plus
            ELSE
                IF  (dest  [1]  = chr (ebcdic_minus)) OR
                    (dest  [1]  = chr (ascii_minus))
                THEN
                    zoned_format := z_sep_leading_minus
                ELSE
                    zoned_format := z_no_separate_sign;
                (*ENDIF*) 
            (*ENDIF*) 
        (*ENDIF*) 
    (*ENDIF*) 
(*ENDIF*) 
IF  (slen = ZONED_MXSP00 - 1) AND (res = num_ok) AND
    (zoned_format = z_no_separate_sign)
THEN
    res := num_invalid;
(*ENDIF*) 
IF  (slen = 1) AND (res = num_ok) AND
    (zoned_format <> z_no_separate_sign)
THEN
    res := num_invalid;
(*ENDIF*) 
IF  res = num_ok
THEN
    CASE zoned_format OF
        z_sep_trailing_minus :
            BEGIN
            slen := slen - 1;
            zoned_dig := ord (dest [ slen] ) MOD 16;
            dest [ slen ] := chr (zoned_minus + zoned_dig);
            END;
        z_sep_trailing_plus :
            BEGIN
            slen := slen - 1;
            zoned_dig := ord (dest [ slen] ) MOD 16;
            dest [ slen ] := chr (zoned_plus + zoned_dig);
            END;
        z_sep_leading_minus :
            BEGIN
            slen := slen - 1;
            FOR i := 1 TO slen DO
                dest  [i]  := dest [ i + 1] ;
            (*ENDFOR*) 
            zoned_dig := ord (dest [ slen] ) MOD 16;
            dest [ slen ] := chr (zoned_minus + zoned_dig);
            END;
        z_sep_leading_plus :
            BEGIN
            slen := slen - 1;
            FOR i := 1 TO slen DO
                dest  [i]  := dest [ i + 1] ;
            (*ENDFOR*) 
            zoned_dig := ord (dest [ slen] ) MOD 16;
            dest [ slen ] := chr (zoned_plus + zoned_dig);
            END;
        z_no_separate_sign :
            IF  ord (dest [ slen] ) DIV 16 = f_nibble
            THEN
                BEGIN
                zoned_flag := ord (dest  [1] ) DIV 16;
                IF  zoned_flag <> f_nibble
                THEN
                    BEGIN
                    zoned_dig := ord (dest  [1] ) MOD 16;
                    dest  [1]  := chr ( 16 * f_nibble + zoned_dig);
                    zoned_dig := ord (dest [ slen] ) MOD 16;
                    dest [ slen ] := chr ( 16 * zoned_flag + zoned_dig);
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
        END;
    (*ENDCASE*) 
(*ENDIF*) 
END; (* sp41extzonedtozoned *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41zonedtodec (
            VAR source : tsp00_Zoned;
            slen       : integer;
            VAR dest   : tsp00_Decimal;
            VAR res    : tsp00_NumError);
 
CONST
      ascii_plus   = 3;
      ascii_minus  = 7;
      ebcdic_plus  = 12;
      ebcdic_minus = 13;
 
VAR
      i      : integer;
      hi_dig : integer;
      lo_dig : integer;
      dlen   : integer;
      sign   : integer;
      valid  : boolean;
 
BEGIN
res := num_ok;
valid := true;
IF  odd (slen)
THEN
    BEGIN
    FOR i := 1 TO slen DO
        BEGIN
        IF  odd (i)
        THEN
            hi_dig := ord (source  [i] ) MOD 16
        ELSE
            lo_dig := ord (source  [i] ) MOD 16;
        (*ENDIF*) 
        IF  valid AND (i < slen)
        THEN
            valid := (ord (source  [i] ) DIV 16 = 15)
                  OR (ord (source  [i] ) DIV 16 = 3);
        (*ENDIF*) 
        IF  NOT odd (i)
        THEN
            dest [ i DIV 2 ] := chr (hi_dig * 16 + lo_dig);
        (*ENDIF*) 
        END;
    (*ENDFOR*) 
    END
ELSE
    BEGIN
    hi_dig := 0;
    FOR i := 1 TO slen DO
        BEGIN
        IF  odd (i)
        THEN
            lo_dig := ord (source  [i] ) MOD 16
        ELSE
            hi_dig := ord (source  [i] ) MOD 16;
        (*ENDIF*) 
        IF  valid AND (i < slen)
        THEN
            valid := (ord (source  [i] ) DIV 16 = 15)
                  OR (ord (source  [i] ) DIV 16 = 3);
        (*ENDIF*) 
        IF  odd (i)
        THEN
            dest [ (i + 1) DIV 2 ] := chr (hi_dig * 16 + lo_dig);
        (*ENDIF*) 
        END;
    (*ENDFOR*) 
    END;
(*ENDIF*) 
IF  valid
THEN
    BEGIN
    sign := ord (source [ slen] ) DIV 16;
    IF  sign = ascii_plus
    THEN
        sign := ebcdic_plus
    ELSE
        IF  sign = ascii_minus
        THEN
            sign := ebcdic_minus;
        (*ENDIF*) 
    (*ENDIF*) 
    IF  sign < 10 (* hex 'A' *)
    THEN
        valid := false
    ELSE
        BEGIN
        dlen := (slen + 2) DIV 2;
        dest [ dlen ] := chr (hi_dig * 16 + sign);
        END;
    (*ENDIF*) 
    END;
(*ENDIF*) 
IF  NOT valid
THEN
    res := num_invalid;
(*ENDIF*) 
END; (* sp41zonedtodec *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41complement (
            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; (* sp41complement *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41mul10 (
            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; (* sp41mul10 *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41normalize (
            VAR result      : tsp00_Number;
            actl            : integer;
            VAR result_expo : integer);
 
VAR
      more     : boolean;
      i        : integer;
      shift    : integer;
 
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
        sp41left_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; (* sp41normalize *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41left_shift (
            VAR source : tsp00_Number;
            actl       : integer;
            shift      : integer);
 
VAR
      i : integer;
 
BEGIN
IF  odd (shift)
THEN
    BEGIN
    shift := shift - 1;
    sp41mul10 ( 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; (* sp41left_shift *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41unsadd (VAR n : tsp00_Number;
            long_val : boolean);
 
VAR
      left_expo   : integer;
      right_expo  : integer;
      result_expo : integer;
      left_dig    : integer;
      right_dig   : integer;
      carry       : integer;
      result_low  : integer;
      result_high : integer;
      i           : integer;
      length      : integer;
      left        : tsp00_Number;
      right       : tsp00_Number;
      result      : tsp00_Number;
      left_mod    : integer;
 
BEGIN
IF  long_val
THEN
    BEGIN
    length := 6;
    left := csp_comlint;
    END
ELSE
    BEGIN
    length := 4;
    left := csp_comsint;
    END;
(*ENDIF*) 
right := n;
left_expo := ord (left  [1] );
right_expo := ord (right  [1] );
result_expo := left_expo;
left  [1]  := chr (0);
right  [1]  := chr (0);
IF  right_expo < left_expo
THEN
    sp41right_shift (right, length, left_expo - right_expo);
(* BEGIN add_dec *)
(*ENDIF*) 
carry := 0 ;
FOR i := mxsp_number  DOWNTO 1 DO
    BEGIN
    left_dig := ord (left  [i] );
    right_dig := ord (right  [i] );
    left_mod := left_dig MOD 16;
    result_low := left_mod + right_dig MOD 16 + carry;
    IF  result_low > 9
    THEN
        BEGIN
        result_low := result_low - 10;
        carry := 1;
        END
    ELSE
        carry := 0;
    (*ENDIF*) 
    result_high := left_dig DIV 16 + right_dig DIV 16 + carry;
    IF  result_high > 9
    THEN
        BEGIN
        result_high := result_high - 10;
        carry := 1
        END
    ELSE
        carry := 0;
    (*ENDIF*) 
    result  [i]  := chr (result_high * 16 + result_low);
    END;
(*ENDFOR*) 
(* END add_dec *)
n := result;
n  [1]  := chr (result_expo);
END; (* sp41unsadd *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41right_shift (
            VAR source : tsp00_Number;
            actl       : integer;
            shift      : integer);
 
VAR
      i : integer;
 
BEGIN
IF  odd (shift)
THEN
    BEGIN
    shift := shift - 1;
    sp41div10 (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; (* sp41right_shift *)
 
(*------------------------------*) 
 
PROCEDURE
      sp41div10 (
            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; (* sp41div10 *)
 
.CM *-END-* code ----------------------------------------
.SP 2 
***********************************************************
.PA 
