.CM  SCRIPT , Version - 1.1 , last edited by barbara
.ad 8
.bm 8
.fm 4
.bt $Copyright (c) 2000-2004 SAP AG$$Page %$
.tm 12
.hm 6
.hs 3
.TT 1 $SQL$Project Distributed Database System$VIN40$
.tt 2 $$$
.TT 3 $$Masked-Output$1997-01-31$
***********************************************************
.nf
 
.nf
 
 
    ========== licence begin  GPL
    Copyright (c) 2000-2004 SAP AG
 
    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.
 
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
 
    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    ========== licence end
 
.fo
 
 
.fo
.nf
.sp
MODULE  : Masked-Output
=========
.sp
Purpose : Precompilation of masks and output of DDB4 variables
          using defined and precompiled masks
.CM *-END-* purpose -------------------------------------
.sp
Define  :
 
        PROCEDURE
              i40parsemask (
                    VAR mask    : tin_c250;
                    maxlen      : tin_natural;
                    VAR act_len : tin_natural;
                    VAR err     : tin_mk_p_error;
                    VAR errpos  : tin_natural);
 
        PROCEDURE
              i40writevariable (
                    VAR mask          : tin_c250;
                    mask_len          : tin_natural;
                    VAR vdn_number    : tsp00_Buf;
                    input_len         : tin_natural;
                    VAR outputfield   : tin_c250;
                    VAR output_len    : tin_natural;
                    VAR err           : tin_mk_w_error);
 
        PROCEDURE
              i40standardmask (
                    dlen        : tin_natural;
                    dfrac       : integer;
                    dec         : tsp_decimal_presentation;
                    VAR mask    : tin_c250;
                    maxlen      : tin_natural;
                    VAR act_len : tin_natural;
                    VAR error   : tin_mk_p_error);
 
        FUNCTION
              in4030 : tsp00_Int4;
 
.CM *-END-* define --------------------------------------
.CM %if %not doku
.CM %begin
.sp;.cp 3
Use     :
 
        FROM
              Kernel_move_and_fill : VGG101;
 
        PROCEDURE
              SAPDB_PascalForcedFill (
                    size        : tsp00_Int4;
                    m           : tsp00_MoveObjPtr;
                    pos         : tsp00_Int4;
                    len         : tsp00_Int4;
                    fillchar    : char);
 
        PROCEDURE
              SAPDB_PascalForcedMove (
                    source_upb  : tsp00_Int4;
                    destin_upb  : tsp00_Int4;
                    source      : tsp00_MoveObjPtr;
                    source_pos  : tsp00_Int4;
                    destin      : tsp00_MoveObjPtr;
                    destin_pos  : tsp00_Int4;
                    length      : tsp00_Int4);
 
        PROCEDURE
              s10mv (
                    source_upb  : tsp00_Int4;       
                    destin_upb  : tsp00_Int4;
                    source      : tsp00_MoveObjPtr;    
                    source_pos  : tsp00_Int4;
                    destin      : tsp00_MoveObjPtr;    
                    destin_pos  : tsp00_Int4;
                    length      : tsp00_Int4);
 
      ------------------------------ 
 
        FROM
              GETSTRING-Conversions : VSP42;
 
        PROCEDURE
              s42gstr (
                    VAR buf  : tsp00_Number;
                    pos      : tsp00_Int4;
                    len      : integer;
                    frac     : integer;
                    origlen  : integer;
                    VAR dest : tsp00_C40;
                    dpos     : tsp00_Int4;
                    VAR dlen : integer;
                    VAR res  : tsp00_NumError);
 
      ------------------------------ 
 
        FROM
              Number-Arithmetic : VSP51;
 
        PROCEDURE
              s51round (VAR source : tsp00_Number;
                    spos : tsp00_Int4;
                    slen : integer;
                    round : integer;
                    VAR result : tsp00_Number;
                    respos : tsp00_Int4;
                    reslen : integer;
                    resfrac : integer;
                    VAR resbytelen : integer;
                    VAR ret : tsp00_NumError);
 
.CM *-END-* use -----------------------------------------
.sp;.cp 3
Synonym :
 
        PROCEDURE
              s42gstr;
 
              tsp00_MoveObj tsp00_Number
              tsp00_MoveObj tsp00_C40
 
        PROCEDURE
              m90buf;
 
              tsp00_Buf tin_c250
 
        PROCEDURE
              m90buf1;
 
              tsp00_Buf tsp00_C40
 
        PROCEDURE
              m90buf3;
 
              tsp00_Buf tsp00_Number
 
        PROCEDURE
              s51round;
 
              tsp00_MoveObj tsp00_Number
 
.CM *-END-* synonym -------------------------------------
.sp;.cp 3
Author  :
.sp
.cp 3
Created : 1985-09-02
.sp
.cp 3
.CM %end
.cp 3
Release :  6.2.8.0       Date : 1997-01-31
.sp
.pb \
.sp
***********************************************************
.sp
.cp 10
.fo
.oc _/1
Specification:
 
Eine Maske gibt an, in welcher Darstellung eine (RDS-) Variable
dargestellt werden soll.
.sp
Sie ist eine alphanumerische Zeichenkette aus
druckbaren Zeichen, von denen einige nach den unten aufgef?uhrten
Regeln eine Sonderbedeutung haben.
Die restlichen Zeichen werden unbearbeitet in die Ausgabe
?ubernommen.
.sp 2;.cp 6;.nf;Definitionen
------------
.fo;.sp2;.in +20;.un 20
Text: Jedes Zeichen, das nach den folgenden Regeln
nicht als besonderes Zeichen erkannt wird, wird direkt ausgegeben.
Der so definierte Text kann auch in die Ausgabe von Zahlen
eingestreut werden.
.br;Grunds?atzlich werden alle Zeichen, die durch das Zeichen: "
("G?ansef?u?zchen") eingeklammert sind, als Text
ausgegeben.
.sp;.un 20;Ziffernfeld: Steht in der Maske eines der Zeichen
"9" oder "5",
so wird dort eine Ziffer der Variablen ausgegeben.
.sp;In speziellen F?allen definieren auch die Zeichen
.br;"*", "0" oder ">" eine Ziffer. Wegen ihrer Sonderbedeutung
sind sie weiter unten extra aufgef?uhrt.
.sp;.un 20
Nachkommastellen: Wird ein Ziffernfeld nur durch Neunen
(und ggf. mit "*", "0" oder ">")
festgelegt, so wird das am weitesten rechts stehende
der Zeichen "." oder "," (Punkt bzw. Komma) als
Dezimaltrennung definiert und legt gleichzeitig die Anzahl
der Nachkommastellen fest.
.br;Dieses Zeichen darf dann nicht noch einmal in dem
Ziffernfeld vorkommen. (Ausnahme: Klammerung durch Gansef?u?zchen)
.sp;Will man andere Zeichen als Dezimalpunkt oder -Komma als
Trennung verwenden, so mu?z man
.oc _/1;alle
Nachkommastellen durch F?unfen ("5") kennzeichnen.
In diesem Fall verlieren Punkt und Komma ihre besondere Bedeutung.
.sp;Sind weder durch Punkt, Komma noch durch F?unfen Nachkomma-
stellen definiert, so werden nur Vorkomma-
stellen ausgegeben.
.sp;.un 20;F?uhrende\Nullen: Die Null ("0") als erste Stelle
einer Zifferndefinition bestimmt, da?z f?uhrende Nullen
ausgegeben werden. Die Null geh?ort
mit zum Ziffernfeld.
Sind keine f?uhrenden Nullen gefordert, werden sie durch Leerzeichen
ersetzt.
.sp;.un 20;Scheckschutz: Das Zeichen "*"
als erste Stelle
einer Zifferndefinition bestimmt, da?z f?uhrende Nullen
durch das Zeichen "*" ersetzt werden.
Das Zeichen "*" geh?ort mit zum Ziffernfeld.
.sp;.un 20;Gleitender\Text: Steht zwischen einem
Text und dem ersten Ziffernfeld ein ">" (Gr?o?zer-Zeichen),
so wird der gesamte Text vor ">" rechtsb?undig
an die werth?ochste Ziffer angeschlossen.
.br;Das ">" geh?ort zum Ziffernfeld.
.sp;.un 20;Vorzeichen: Es wird durch "+" oder "-" angegeben.
Es darf nur unmittelbar vor dem Beginn oder am Ende des gesamten
Zahlfeldes stehen. In der Kombination "+>" oder "->" wird es gleitend,
d.h. unmittelbar vor der ersten Ziffer, sonst in der Spalte
ausgegeben, wo es steht.
.br;Bei "-" wird nur das negative Vorzeichen (sonst Blank),
bei "+" sowohl das negative als auch das positive Vorzeichen
ausgegeben.
.br;Kombinationen mit f?uhrenden Nullen oder Scheckschutz
sind m?oglich: Bei f?uhrenden Nullen nur "+099..." bzw.
"-099...", bei Scheckschutz
"+*99..." bzw. "-*99..." (festes Vorzeichen vor dem Scheckschutz).
.br;Wird nichts angegeben, so wird das Vorzeichen
wie bei einem gleitenden "-" vor der Zahl ausgegeben.
.sp;.un 20;Zehnerpotenzen: ("wissenschaftliche Notation")
Man kann die Zahlausgabe in der wissenschaftlichen Darstellung,
d.h. mit Angabe von Zehnerpotenzen fordern:
.br;Die Kombination "E+", "E-", "e+"oder "e-" unmittelbar vor
einer "9" definiert ein Feld f?ur die Ausgabe der Zehnerpotenzen.
Sie werden in jedem Fall mit Vorzeichen und f?uhrenden Nullen
ausgegeben.
.in -20;.sp 2
Grunds?atzlich werden die Vorkommastellen und die Zehnerpotenz
.oc _/1;rechtsb?undig,
die Nachkommastellen
.oc _/1;linksb?undig
in die vorgesehenen Felder eingetragen.
.sp
Sind keine f?uhrenden Nullen gefordert, so werden in die
Zahldarstellung eingestreute Textteile unterdr?uckt,
sobald vor diesen Textteilen keine Ziffern mehr stehen;
Stattdessen werden Blanks ausgegeben.
.sp 2;.cp 20;.nf;Beispiele:
----------
.fo;.sp2
Nehmen wir als Variable, die ausgegeben werden soll, die Zahl
.nf;.sp
                    1234.567
an:
.sp;.cp 16
         Maske              |           Ausgabe
----------------------------|-----------------------------------
  999999.999                |        1234.567
  999 999,999               |        1 234,567
  *99999,999                |      **1234,567
  099999,999                |      001234,567
  +999999,999               |      +  1234,567
  999999,999+               |        1234,567+
  +>99999,999               |        +1234,567
  9,9999999E+99             |      1,2345670E+03
  999 999 DM 55 PF          |        1 234 DM 57 PF
  999 Tausend 999 DM 55 PF  |        1 Tausend 234 DM 57 PF
  999 Mio 999 Tsd 999 DM    |                1 Tsd 234 DM
  099 Mio 999 Tsd 999 DM    |      000 Mio 001 Tsd 234 DM
  Guthaben: *999 999,55 DM  |      Guthaben: ****1 234,57 DM
  Stand "02.09.85": 9 999DM |      Stand 02.09.85: 1 234DM
.pa
.nf;Schnittstelle
-------------
.sp 2
Folgende Aufz?ahlungstypen:
.sp;TYPE
      ti_mk_p_error = (mk_ok,empty,wrong_digitnumber,double_definition,
                  quotes_not_closed,wrong_pos,mask_too_long);
      ti_mk_w_error = (mk_w_ok,var_too_long,mk_ill_var);
.sp;fo;bezeichnen Fehlersituationen, die bei den betreffenden
Prozeduren n?aher erl?autert werden.
.sp;.nf;(*------------------------------*)
.sp
        PROCEDURE
              i40parsemask(VAR mask : ti_c250;
                          maxlen      : ti_natural;
                          VAR act_len : ti_natural;
                          VAR err     : ti_mk_p_error;
                          VAR errpos  : ti_natural);
.fo;.sp 2;
Pr?uft die eingegebene Maske auf Syntaxfehler und wandelt
sie in ein internes, schneller auszuf?uhrendes Format um.
hi 15;.sp 2
MASK: enth?alt beim Aufruf die (z.B. vom Benutzer eingegebene) Maske.
.br;Nach dem R?ucksprung enth?alt sie die Maske in interner Darstellung.
.sp;MAXLEN: maximale L?ange des Maskenfelds mask wie definiert
(f?ur Synonym).
.sp;ACT_LEN: enth?alt beim Aufruf die aktuelle L?ange der
Ausgangsmaske,
.br;nach dem R?ucksprung die aktuelle L?ange
der ?ubersetzten Maske.
Sie wird i.a. 3 Bytes gro?zer als beim Aufruf.
.sp;ERR: enth?alt ggf. einen Fehlercode
.sp;ERRPOS: ggf. die Position des
ersten gefundenen Fehlers in der Ausgangsmaske.
.hi 0;.nf;.cp 10
 
(*------------------------------*)
 
        PROCEDURE
              i40writevariable(VAR mask   : ti_c250;
                          mask_len          : ti_natural;
                          VAR vdn_number    : buffer;
                          input_len         : ti_natural;
                          VAR outputfield   : ti_c250;
                          VAR output_len    : ti_natural;
                          VAR err           : ti_mk_w_error);
.fo;.sp 2
Gibt die RDS-Variable, die in VDN_NUMBER angeliefert wird,
gem?a?z der Maskendefinition aus.
Die Maske mu?z bereits mit i40parsemask ?ubersetzt
oder mit i40standardmask erzeugt worden sein.
.br;Dabei wird die Umwandlung von VDN-Number in lesbares Format
vorgenommen.
.sp;.oc _/1;Fehlersituationen:
.sp;Ist die angegebene Variable l?anger als f?ur VDN_NUMERs erlaubt,
wird in ERR der Fehlercode VAR_TOO_LONG zur?uckgegeben; in diesem
Fall bleibt das Ausgabefeld undfiniert.
.sp;Ist die Variable zwar eine g?ultige VDN-Number,
aber doch zu gro?z f?ur die Maske, so
wird in ERR der Fehlercode MK_ILL_VAR zur?uckgeliefert,
und die entsprechenden Stellen werden mit Sternen ("*")
ausgef?ullt.
.hi 15;.sp 2
MASK: Die bereits von i40parsemask vor?ubersetzte Maske
.sp;MASK_LEN: aktuelle L?ange der vor?ubersetzten Maske
(wie von i40parsemask zur?uckgeliefert).
.sp;VDN_NUMBER: Feld, das den Wert der auszugebenden
Variablen enth?alt.
.sp;INPUT_LEN: aktuelle L?ange des Strings in vdn_number.
.sp;OUTPUTFIELD: enth?alt nach dem R?ucksprung den
Wert der Variablen in lesbarer Form gem?a?z der Maskendefinition.
.sp;MAXLEN: maximale L?ange von OUTPUTFIELD, wie definiert.
.sp;OUTPUT_LEN: aktuelle L?ange des Werts in OUTPUTFIELD.
.sp;ERR: ggf. Fehlercode ( siehe obige Bemerkungen)
.hi 0;.sp;.nf
(*------------------------------*)
.sp
        PROCEDURE
              i40standardmask(dlen   : ti_natural;
                          dfrac       : integer;
                          dec         : decimal_presentation;
                          VAR mask    : ti_c250;
                          maxlen      : ti_natural;
                          VAR act_len : ti_natural;
                          VAR error   : ti_mk_p_error);
.fo;.sp 2
Erzeugt eine Standardmaske f?ur den in DTYPE definierten Typ,
bereits in vor?ubersetzter Form, so da?z unmittelbar anschlie?zend
I40_WRITE_VARIABLE
aufgerufen werden kann.
.hi 15;.sp 2
DTYPE: Hier definiert man den Typ und die L?angen f?ur die
auszigebende Variable.
.sp;DEC: enth?alt beim Aufruf die Dezimaldarstellung
(Dezimalpunkt, Tausendertrennzeichen), z.B. aus i01g^.set_parms.
.sp;MASK: enth?alt beim R?ucksprung die Standardmaske in
bereits vor?ubersetzter Form.
.sp;MAXLEN: mu?z beim Aufruf mit der maximalen L?ange der Maske
belegt werden.
.sp;ACT_LEN: enth?alt beim R?ucksprung die aktuelle L?ange
der (?ubersetzten) Maske.
.sp;ERROR: enth?alt beim R?ucksprung ggf. einen Fehlercode:
.br;WRONG_DIGITNUMBER, falls DLEN oder DFRAC nicht korrekt angegeben
wurden,
.br;MASK_TOO_LONG, wenn die Standardmaske die angegebene Maximall?ange
?uberschreitet.
.hi 0
.CM %end
.CM *-END-* specification -------------------------------
.sp 2
.CM %if %not doku
.CM %begin
***********************************************************
.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
      maxdigitnumber  =  38; (* 18; *)
      zero            = '0';
      number_symbol   = '9';
      fraction_symbol = '5';
      comma_char      = ',';
      point_char      = '.';
      expo_char1      = 'E';
      expo_char2      = 'e';
      double_quote    = '"';
      plus_sign       = '+';
      minus_sign      = '-';
      credit_char1    = 'C';
      credit_char2    = 'R';
      debit_char1     = 'D';
      debit_char2     = 'B';
      float_symbol    = '>';
      protect_char    = '*';
      lead_z_char     = zero;
      max_expo_len    = 2;
      (* second pass *)
      (* type codes: field_type *)
      max_fieldtype   = 20;
      sign_opt        = 0;
      sign_obl        = 1;
      e_char1         = 3;
      e_char2         = 4;
      one_edigit      = 5;
      sign_credit     = 6;
      sign_debit      = 7;
      number_field    = 10;
      (* type codes: number_field - subtype *)
      lead_blanks_or_sign = 0;
      lead_blanks         = 1;
      leading_zero        = 2;
      sign_or_zero        = 3;
      floating_text       = 4;
      float_or_sign       = 5;
      number_protected    = 6;
      protect_or_sign     = 7;
      (*                        *)
      (*    i40_write_...       *)
      (*                        *)
      overflow_char = '*';
      maxdigitlength = 38; (* 18; *)
      l_maskheader = 3;
      first_number_pos = 1;
 
TYPE
      fp_status = (fp_nothing,search_dpoint,frac_begin,
            dpos_found,dpoint_found,dcomma_found,number_finished);
      rds_datatype = (rds_fixed,rds_float,rds_char,rds_byte);
      masklength = 0 .. 250;
      mask_pos = masklength;
 
      mask_descriptor = RECORD
            dtype    : rds_datatype;
            datalen  : 0 .. maxdigitnumber;
            datafrac : 0 .. maxdigitnumber;
            firstpos : mask_pos;
            lastpos  : mask_pos;
            d_pos    : mask_pos;
            e_pos    : mask_pos;
            protect  : char;
            sign_implicit : boolean;
      END;
 
 
      internal_mask = RECORD
            len  : masklength;
            ppos : mask_pos;
            buf  : tin_c250;
      END;
 
      (* second pass *)
      field_type = sign_opt .. max_fieldtype;
      (* i40_write_... *)
 
      number_string = RECORD
            buf : tsp00_C40;
            ppos : 0..40;
            len : 0 .. 40;
            d_pos : 0 .. 40;
            e_pos : 0 .. 40;
            sign : char;
      END;
 
      wrdig_status = (number_not_started,number_started,digits_started);
 
 
(*------------------------------*) 
 
FUNCTION
      in4030 : tsp00_Int4;
 
BEGIN
(* linkcheck function *)
in4030 := 219000816;
END;
 
(*------------------------------*) 
 
PROCEDURE
      i40parsemask (
            VAR mask    : tin_c250;
            maxlen      : tin_natural;
            VAR act_len : tin_natural;
            VAR err     : tin_mk_p_error;
            VAR errpos  : tin_natural);
 
VAR
      mdesc : mask_descriptor;
      pmask : internal_mask;
      omask : internal_mask;
 
BEGIN
IF  act_len + l_maskheader > maxlen
THEN
    BEGIN
    err := mask_too_long;
    errpos := act_len;
    END
ELSE
    BEGIN
    WITH pmask DO
        BEGIN
        len := act_len;
        s10mv (250,250,
              @mask,1,
              @buf,1,len);
        END;
    (*ENDWITH*) 
    first_pass (pmask, mdesc, err);
    omask.len := maxlen;
    IF  err = mk_ok
    THEN
        second_pass (pmask, mdesc, omask, err);
    (*ENDIF*) 
    IF  err <> mk_ok
    THEN
        errpos := pmask.ppos;
    (*ENDIF*) 
    IF  err = mk_ok
    THEN
        WITH omask DO
            BEGIN
            act_len := ppos;
            s10mv (250,250,
                  @buf,1,
                  @mask,1,len);
            END;
        (*ENDWITH*) 
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* i40parsemask *)
 
(*------------------------------*) 
 
PROCEDURE
      first_pass (
            VAR pmask : internal_mask;
            VAR mdesc : mask_descriptor;
            VAR err   : tin_mk_p_error);
 
VAR
      act_char : char;
      pstat : fp_status;
 
BEGIN
init_mdesc (mdesc);
pstat := fp_nothing;
WITH pmask DO
    BEGIN
    ppos := len;
    err := mk_ok;
    WHILE (ppos > 0) AND (err = mk_ok) DO
        BEGIN
        act_char := buf [ppos] ;
        CASE act_char OF
            number_symbol:
                fp_case_digit (pstat, mdesc, ppos, err);
            fraction_symbol:
                fp_case_fraction (pstat, mdesc, ppos, err);
            comma_char:
                fp_case_dpoint (pstat, dcomma_found, mdesc, ppos, err);
            point_char:
                fp_case_dpoint (pstat, dpoint_found, mdesc, ppos, err);
            expo_char1, expo_char2:
                fp_case_expo (pstat, mdesc, pmask, err);
            double_quote:
                skip_quotes (pmask, err);
            float_symbol,
            protect_char, lead_z_char:
                fp_case_protect (pstat, mdesc, pmask, err);
            plus_sign, minus_sign, credit_char1, debit_char1:
                fp_case_sign (mdesc, pmask, err);
            OTHERWISE:
                ppos := ppos -1;
            END;
        (*ENDCASE*) 
        END;
    (*ENDWHILE*) 
    IF  err = mk_ok
    THEN
        fp_case_finished (pstat, mdesc, ppos, err);
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* first_pass *)
 
(*------------------------------*) 
 
PROCEDURE
      init_mdesc (
            VAR mdesc : mask_descriptor);
 
BEGIN
WITH mdesc DO
    BEGIN
    firstpos := 0;
    lastpos  := 0;
    datalen  := 0;
    datafrac := 0;
    d_pos    := 0;
    e_pos    := 0;
    protect  := bsp_c1;
    sign_implicit := true;
    END;
(*ENDWITH*) 
END; (* init_mdesc *)
 
(*------------------------------*) 
 
PROCEDURE
      fp_case_digit (
            VAR pstat : fp_status;
            VAR mdesc : mask_descriptor;
            VAR ppos  : mask_pos;
            VAR err   : tin_mk_p_error);
 
BEGIN
WITH mdesc DO
    IF  datalen = maxdigitnumber
    THEN
        err := wrong_digitnumber
    ELSE
        IF  pstat = number_finished
        THEN
            err := wrong_pos
        ELSE
            BEGIN
            datalen := datalen + 1;
            firstpos := ppos;
            protect := bsp_c1;
            CASE pstat OF
                fp_nothing:
                    BEGIN
                    lastpos := ppos;
                    pstat := search_dpoint;
                    END;
                frac_begin:
                    BEGIN
                    pstat := dpos_found;
                    d_pos := ppos;
                    datafrac := datalen - 1;
                    END;
                dpoint_found, dcomma_found:
                    IF  d_pos = 0
                    THEN
                        d_pos := ppos;
                    (*ENDIF*) 
                OTHERWISE:
                END;
            (*ENDCASE*) 
            ppos := ppos - 1;
            END;
        (*ENDIF*) 
    (*ENDIF*) 
(*ENDWITH*) 
END; (* fp_case_digit *)
 
(*------------------------------*) 
 
PROCEDURE
      fp_case_fraction (
            VAR pstat : fp_status;
            VAR mdesc : mask_descriptor;
            VAR ppos  : mask_pos;
            VAR err   : tin_mk_p_error);
 
BEGIN
WITH mdesc DO
    IF  datalen = maxdigitnumber
    THEN
        err := wrong_digitnumber
    ELSE
        BEGIN
        datalen := datalen + 1;
        firstpos := ppos;
        CASE pstat OF
            fp_nothing:
                BEGIN
                lastpos := ppos;
                pstat := frac_begin;
                END;
            search_dpoint, dpos_found,
            dpoint_found, dcomma_found, number_finished:
                err := wrong_pos;
            OTHERWISE:
            END;
        (*ENDCASE*) 
        IF  err = mk_ok
        THEN
            ppos := ppos - 1;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
(*ENDWITH*) 
END; (* fp_case_fraction *)
 
(*------------------------------*) 
 
PROCEDURE
      fp_case_dpoint (
            VAR pstat : fp_status;
            i40switch : fp_status;
            VAR mdesc : mask_descriptor;
            VAR ppos  : mask_pos;
            VAR err   : tin_mk_p_error);
 
BEGIN
WITH mdesc DO
    BEGIN
    CASE pstat OF
        search_dpoint:
            BEGIN
            pstat := i40switch;
            datafrac := datalen;
            (* d_pos will be set later *)
            END;
        dpoint_found, dcomma_found:
            IF  pstat = i40switch
            THEN
                err := double_definition;
            (*ENDIF*) 
        OTHERWISE:
        END;
    (*ENDCASE*) 
    IF  err = mk_ok
    THEN
        ppos := ppos - 1;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* fp_case_dpoint *)
 
(*------------------------------*) 
 
PROCEDURE
      fp_case_expo (
            VAR pstat : fp_status;
            VAR mdesc : mask_descriptor;
            VAR pmask : internal_mask;
            VAR err   : tin_mk_p_error);
 
BEGIN
WITH mdesc, pmask DO
    IF  NOT expo_found (pmask)
    THEN
        ppos := ppos - 1
    ELSE
        IF  e_pos > 0
        THEN
            err := double_definition
        ELSE
            IF  pstat IN [ frac_begin, dpos_found,
                dpoint_found, dcomma_found ]
            THEN
                err := wrong_pos
            ELSE
                IF  datalen > max_expo_len
                THEN
                    err := wrong_digitnumber
                ELSE
                    BEGIN
                    e_pos := ppos;
                    datalen := 0;
                    datafrac := 0;
                    pstat := fp_nothing;
                    ppos := ppos - 1;
                    END;
                (*ENDIF*) 
            (*ENDIF*) 
        (*ENDIF*) 
    (*ENDIF*) 
(*ENDWITH*) 
END; (* fp_case_expo *)
 
(*------------------------------*) 
 
FUNCTION
      expo_found (
            VAR pmask : internal_mask) : boolean;
 
VAR
      found : boolean;
 
BEGIN
found := true;
WITH pmask DO
    BEGIN
    IF  (ppos > (len - 2)) OR (ppos < 1)
    THEN
        found := false;
    (*ENDIF*) 
    IF  found
    THEN
        found := buf [ppos ] IN [ expo_char1, expo_char2] ;
    (*ENDIF*) 
    IF  found
    THEN
        found := (buf [ppos + 1 ] IN [ plus_sign, minus_sign ] );
    (*ENDIF*) 
    IF  found
    THEN
        found := buf [ppos + 2 ] = number_symbol;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
expo_found := found;
END; (* expo_found *)
 
(*------------------------------*) 
 
FUNCTION
      cr_db_found (
            VAR pmask : internal_mask) : boolean;
 
VAR
      found : boolean;
 
BEGIN
found := true;
WITH pmask DO
    BEGIN
    IF  ppos >= len
    THEN
        found := false;
    (*ENDIF*) 
    IF  found
    THEN
        found := (buf [ppos ] = credit_char1) AND
              (buf [ppos + 1 ] = credit_char2) OR
              (buf [ppos ] = debit_char1) AND
              (buf [ppos + 1 ] = debit_char2);
    (*ENDIF*) 
    END;
(*ENDWITH*) 
cr_db_found := found;
END; (* cr_db_found *)
 
(*------------------------------*) 
 
PROCEDURE
      skip_quotes (
            VAR pmask : internal_mask;
            VAR err   : tin_mk_p_error);
 
VAR
      quote_found : boolean;
 
BEGIN
WITH pmask DO
    BEGIN
    quote_found := false;
    REPEAT
        ppos := ppos - 1;
        IF  ppos = 0
        THEN
            err := quotes_not_closed
        ELSE
            quote_found := buf [ppos ] = double_quote;
        (*ENDIF*) 
    UNTIL
        quote_found OR (err <> mk_ok);
    (*ENDREPEAT*) 
    IF  quote_found
    THEN
        ppos := ppos - 1;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* skip_quotes *)
 
(*------------------------------*) 
 
PROCEDURE
      fp_case_protect (
            VAR pstat : fp_status;
            VAR mdesc : mask_descriptor;
            VAR pmask : internal_mask;
            VAR err   : tin_mk_p_error);
 
BEGIN
WITH pmask DO
    IF  pstat IN [ fp_nothing, frac_begin, number_finished ]
    THEN
        err := wrong_pos
    ELSE
        WITH mdesc DO
            IF  datalen = maxdigitnumber
            THEN
                err := wrong_digitnumber
            ELSE
                BEGIN
                protect := buf [ppos] ;
                IF  (ppos = 1) AND (protect = float_symbol)
                THEN
                    err := wrong_pos
                ELSE
                    BEGIN
                    IF  protect = lead_z_char
                    THEN
                        protect := zero;
                    (*ENDIF*) 
                    datalen := datalen + 1;
                    firstpos := ppos;
                    fp_case_finished (pstat, mdesc, ppos, err);
                    ppos := ppos - 1;
                    END;
                (*ENDIF*) 
                END;
            (*ENDIF*) 
        (*ENDWITH*) 
    (*ENDIF*) 
(*ENDWITH*) 
END; (* fp_case_protect *)
 
(*------------------------------*) 
 
PROCEDURE
      fp_case_sign (
            VAR mdesc : mask_descriptor;
            VAR pmask : internal_mask;
            VAR err   : tin_mk_p_error);
 
VAR
      is_sign : boolean;
 
BEGIN
WITH mdesc, pmask DO
    BEGIN
    IF  buf [ppos ] in [ plus_sign, minus_sign ]
    THEN
        BEGIN
        ppos := ppos - 1;
        is_sign := NOT expo_found (pmask);
        END
    ELSE
        BEGIN
        is_sign := cr_db_found (pmask);
        ppos := ppos - 1;
        END;
    (*ENDIF*) 
    IF  is_sign
    THEN
        IF  NOT sign_implicit
        THEN
            BEGIN
            ppos := ppos + 1;
            err := double_definition
            END
        ELSE
            sign_implicit := false;
        (*ENDIF*) 
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* fp_case_sign *)
 
(*------------------------------*) 
 
PROCEDURE
      fp_case_finished (
            VAR pstat : fp_status;
            VAR mdesc : mask_descriptor;
            VAR ppos  : mask_pos;
            VAR err   : tin_mk_p_error);
 
BEGIN
IF  pstat = fp_nothing
THEN
    err := empty
ELSE
    WITH mdesc DO
        BEGIN
        CASE pstat OF
            search_dpoint:
                BEGIN
                datafrac := 0;
                d_pos := lastpos;
                END;
            frac_begin:
                BEGIN
                datafrac := datalen;
                d_pos := ppos;
                END;
            dpoint_found, dcomma_found:
                IF  d_pos = 0
                THEN
                    d_pos := ppos;
                (*ENDIF*) 
            OTHERWISE:
            END;
        (*ENDCASE*) 
        IF  pstat <> number_finished
        THEN
            BEGIN
            pstat := number_finished;
            IF  e_pos > 0
            THEN
                dtype := rds_float
            ELSE
                dtype := rds_fixed;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDWITH*) 
(*ENDIF*) 
END; (* fp_case_finished *)
 
(*------------------------------*) 
 
PROCEDURE
      second_pass (
            VAR imask : internal_mask;
            VAR mdesc : mask_descriptor;
            VAR omask : internal_mask;
            VAR err   : tin_mk_p_error);
 
VAR
      act_char : char;
      number_ft : field_type;
      quotes_on : boolean;
 
BEGIN
put_mdesc (mdesc, omask);
get_ntype (mdesc, number_ft);
WITH imask DO
    BEGIN
    ppos := 0;
    quotes_on := false;
    WHILE (ppos < len) AND (err = mk_ok) DO
        BEGIN
        ppos := ppos + 1;
        IF  ppos = mdesc.e_pos
        THEN
            sp_case_expo (imask, omask)
        ELSE
            BEGIN
            act_char := buf [ppos] ;
            IF  act_char = double_quote
            THEN
                quotes_on := NOT quotes_on
            ELSE
                IF  quotes_on
                THEN
                    sp_case_text (act_char, omask)
                ELSE
                    CASE act_char OF
                        number_symbol, fraction_symbol,
                        float_symbol, protect_char, lead_z_char:
                            sp_case_digit (number_ft, omask);
                        plus_sign, minus_sign,
                        credit_char1, debit_char1:
                            IF  act_char in [ plus_sign, minus_sign ]
                            THEN
                                sp_case_sign (imask, mdesc, omask, err)
                            ELSE
                                IF  cr_db_found (imask)
                                THEN
                                    sp_case_sign (imask, mdesc, omask, err)
                                ELSE
                                    sp_case_text (act_char, omask);
                                (*ENDIF*) 
                            (*ENDIF*) 
                        OTHERWISE:
                            sp_case_text (act_char, omask);
                        END;
                    (*ENDCASE*) 
                (*ENDIF*) 
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        END;
    (*ENDWHILE*) 
    END;
(*ENDWITH*) 
END; (* second_pass *)
 
(*------------------------------*) 
 
PROCEDURE
      put_mdesc (
            VAR mdesc : mask_descriptor;
            VAR omask : internal_mask);
 
VAR
      err : tin_mk_p_error;
 
BEGIN
err := mk_ok;
WITH omask, mdesc DO
    BEGIN
    buf [1]  := chr (ord (dtype));
    buf [2]  := chr (datalen);
    buf [3]  := chr (datafrac);
    ppos := 3;
    END;
(*ENDWITH*) 
END; (* put_mdesc *)
 
(*------------------------------*) 
 
PROCEDURE
      get_ntype (
            VAR mdesc     : mask_descriptor;
            VAR number_ft : field_type);
 
VAR
      subtype : field_type;
 
BEGIN
number_ft := number_field;
WITH mdesc DO
    CASE protect OF
        protect_char:
            IF  sign_implicit
            THEN
                subtype := protect_or_sign
            ELSE
                subtype := number_protected;
            (*ENDIF*) 
        float_symbol:
            IF  sign_implicit
            THEN
                subtype := float_or_sign
            ELSE
                subtype := floating_text;
            (*ENDIF*) 
        zero:
            IF  sign_implicit
            THEN
                subtype := sign_or_zero
            ELSE
                subtype := leading_zero;
            (*ENDIF*) 
        bsp_c1:
            IF  sign_implicit
            THEN
                subtype := lead_blanks_or_sign
            ELSE
                subtype := lead_blanks;
            (*ENDIF*) 
        END;
    (*ENDCASE*) 
(*ENDWITH*) 
number_ft := number_ft + subtype;
END; (* get_ntype *)
 
(*------------------------------*) 
 
PROCEDURE
      sp_case_digit (
            VAR number_ft : field_type;
            VAR omask     : internal_mask);
 
BEGIN
WITH omask DO
    BEGIN
    ppos := ppos + 1;
    buf [ppos ] := chr (number_ft);
    IF  number_ft = number_field + sign_or_zero
    THEN
        number_ft := number_field + leading_zero;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* sp_case_digit *)
 
(*------------------------------*) 
 
PROCEDURE
      sp_case_sign (
            VAR imask : internal_mask;
            VAR mdesc : mask_descriptor;
            VAR omask : internal_mask;
            VAR err   : tin_mk_p_error);
 
VAR
      stype : field_type;
      sign_char : char;
 
BEGIN
WITH imask, mdesc DO
    BEGIN
    IF  buf [ppos ] in [ plus_sign, minus_sign ]
    THEN
        IF  ppos IN [ firstpos - 1, lastpos + 1 ]
        THEN
            sign_char := buf [ppos ]
        ELSE
            err := wrong_pos;
        (*ENDIF*) 
    (*ENDIF*) 
    IF  buf [ppos ] in [ credit_char1, debit_char1 ]
    THEN
        IF  ((ppos = firstpos - 2) OR (ppos = lastpos + 1) AND
            (ppos + 1 = len))
        THEN
            sign_char := buf [ppos ]
        ELSE
            err := wrong_pos;
        (*ENDIF*) 
    (*ENDIF*) 
    END;
(*ENDWITH*) 
IF  err = mk_ok
THEN
    BEGIN
    IF  sign_char = plus_sign
    THEN
        stype := sign_obl;
    (*ENDIF*) 
    IF  sign_char = minus_sign
    THEN
        stype := sign_opt;
    (*ENDIF*) 
    IF  sign_char in [ credit_char1, debit_char1 ]
    THEN
        BEGIN
        IF  sign_char = credit_char1
        THEN
            stype := sign_credit
        ELSE
            stype := sign_debit;
        (*ENDIF*) 
        imask.ppos := imask.ppos + 1;
        END;
    (*ENDIF*) 
    WITH omask DO
        BEGIN
        ppos := ppos + 1;
        buf [ppos ] := chr (stype);
        IF  stype in [ sign_credit, sign_debit ]
        THEN
            BEGIN
            ppos := ppos + 1;
            buf [ppos ] := chr (stype);
            END;
        (*ENDIF*) 
        END;
    (*ENDWITH*) 
    END;
(*ENDIF*) 
END; (* sp_case_sign *)
 
(*------------------------------*) 
 
PROCEDURE
      sp_case_expo (
            VAR imask : internal_mask;
            VAR omask : internal_mask);
 
VAR
      expo_char : char;
      etype     : field_type;
 
BEGIN
WITH imask DO
    expo_char := buf [ppos] ;
(*ENDWITH*) 
IF  expo_char = expo_char1
THEN
    etype := e_char1
ELSE
    etype := e_char2;
(*ENDIF*) 
WITH omask DO
    BEGIN
    ppos := ppos + 1;
    buf [ppos ] := chr (etype);
    (* take sign from variable *)
    ppos := ppos + 1;
    buf [ppos ] := chr (number_field);
    imask.ppos := imask.ppos + 1;
    IF  imask.buf [imask.ppos + 2 ] <> number_symbol
    THEN
        BEGIN
        ppos := ppos + 1;
        buf [ppos ] := chr (one_edigit);
        imask.ppos := imask.ppos + 2;
        END;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* sp_case_expo *)
 
(*------------------------------*) 
 
PROCEDURE
      sp_case_text (
            act_char  : char;
            VAR omask : internal_mask);
 
BEGIN
WITH omask DO
    BEGIN
    ppos := ppos + 1;
    buf [ppos ] := act_char;
    END;
(*ENDWITH*) 
END; (* sp_case_text *)
 
(*------------------------------*) 
 
PROCEDURE
      i40writevariable (
            VAR mask          : tin_c250;
            mask_len          : tin_natural;
            VAR vdn_number    : tsp00_Buf;
            input_len         : tin_natural;
            VAR outputfield   : tin_c250;
            VAR output_len    : tin_natural;
            VAR err           : tin_mk_w_error);
 
VAR
      mdesc           : mask_descriptor;
      internal_number : tsp00_Number;
      w_string        : internal_mask;
      nstring         : number_string;
 
BEGIN
err := mk_w_ok;
get_mdesc (mdesc, mask);
WITH w_string DO
    BEGIN
    len := mask_len - l_maskheader;
    s10mv (250,250,
          @mask,l_maskheader + 1,
          @buf,1,len);
    ppos := 0;
    END;
(*ENDWITH*) 
IF  input_len > mxsp_number
THEN
    err := var_too_long
ELSE
    BEGIN
    s10mv (mxsp_buf,mxsp_number,
          @vdn_number,1,
          @internal_number,1,input_len);
    (*                                                   *)
    (*===================================================*)
    (*===================================================*)
    convert_number (internal_number, input_len, mdesc, nstring, err);
    (*                                                   *)
    write_number (nstring, mdesc, w_string, outputfield, output_len, err);
    (*===================================================*)
    (*===================================================*)
    (*                                                   *)
    END;
(*ENDIF*) 
END; (* i40writevariable *)
 
(*------------------------------*) 
 
PROCEDURE
      get_mdesc (
            VAR mdesc : mask_descriptor;
            VAR mask  : tin_c250);
 
BEGIN
WITH mdesc DO
    BEGIN
    IF  ord (mask [1] ) = ord (rds_fixed)
    THEN
        dtype := rds_fixed
    ELSE
        IF  ord (mask [1] ) = ord (rds_float)
        THEN
            dtype := rds_float;
        (*ENDIF*) 
    (*ENDIF*) 
    datalen := ord (mask [2] );
    datafrac := ord (mask [3] );
    END;
(*ENDWITH*) 
END; (* get_mdesc *)
 
(*------------------------------*) 
 
PROCEDURE
      convert_number (
            VAR vdn_number : tsp00_Number;
            input_len      : tin_natural;
            VAR mdesc      : mask_descriptor;
            VAR nstring    : number_string;
            VAR err        : tin_mk_w_error);
 
VAR
      res        : tsp00_NumError;
      length     : integer;
      resbytelen : integer;
      res_number : tsp00_Number;
      frac       : integer;
      round      : integer;
 
BEGIN
WITH mdesc, nstring DO
    BEGIN
    IF  dtype = rds_fixed
    THEN
        BEGIN
        frac := datafrac;
        round := datafrac;
        END
    ELSE
        BEGIN
        frac := csp_float_frac;
        round := datalen;
        END;
    (*ENDIF*) 
    res_number := csp_null_number;
    s51round (vdn_number, 1, input_len, round, res_number,
          1, datalen, frac, resbytelen, res);
    IF  res IN [ num_ok, num_trunc ]
    THEN
        BEGIN
        s42gstr (res_number, 1, datalen, frac, maxdigitlength,
              buf, 1, length, res);
        len := length;
        set_nstring (mdesc, nstring);
        IF  dtype = rds_float
        THEN
            shift_dpoint (mdesc, nstring);
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    IF  res <> num_ok
    THEN
        BEGIN
        SAPDB_PascalForcedFill (40, @buf, 1, 40, overflow_char);
        err := mk_ill_var;
        len := datalen;
        IF  frac > 0
        THEN
            len := len + 1;
        (*ENDIF*) 
        ppos := 1;
        sign := bsp_c1;
        END;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* convert_number *)
 
(*------------------------------*) 
 
PROCEDURE
      set_nstring (
            VAR mdesc   : mask_descriptor;
            VAR nstring : number_string);
 
VAR
      v_anz : 0 .. maxdigitnumber;
 
BEGIN
WITH nstring DO
    IF  mdesc.dtype = rds_fixed
    THEN
        BEGIN
        v_anz := mdesc.datalen - mdesc.datafrac;
        d_pos := v_anz + 1;
        e_pos := 0;
        IF  v_anz = 0
        THEN
            BEGIN
            (* leading zero from getstr *)
            d_pos := d_pos + 1;
            ppos := d_pos + 1;
            END
        ELSE
            ppos  := first_number_pos;
        (*ENDIF*) 
        search_sign (nstring);
        END
    ELSE
        BEGIN  (* !!! *)
        IF  mdesc.datalen = 1
        THEN
            d_pos := 2
        ELSE
            d_pos := 3;
        (*ENDIF*) 
        e_pos := mdesc.datalen + d_pos;
        sign := buf [1] ;
        IF  sign = bsp_c1
        THEN
            sign := plus_sign;
        (*ENDIF*) 
        ppos  := first_number_pos;
        END;
    (*ENDIF*) 
(*ENDWITH*) 
END; (* set_nstring *)
 
(*------------------------------*) 
 
PROCEDURE
      search_sign (
            VAR nstring : number_string);
 
VAR
      pos : 0 .. 40;
 
BEGIN
WITH nstring DO
    BEGIN
    pos := 0;
    REPEAT
        pos := pos + 1
    UNTIL
        (buf [pos ] IN [  zero .. '9' ] )
        OR (pos = 40); (* pz 28.10.86 wg. HB *)
    (*ENDREPEAT*) 
    sign := buf [pos - 1] ;
    IF  (sign = bsp_c1)
    THEN
        sign := plus_sign;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* search_sign *)
 
(*------------------------------*) 
 
PROCEDURE
      shift_dpoint (
            VAR mdesc   : mask_descriptor;
            VAR nstring : number_string);
 
VAR
      e_frac     : 0 .. maxdigitnumber;
      difference : integer;
 
BEGIN
WITH nstring DO
    BEGIN
    IF  mdesc.datalen > 1
    THEN
        BEGIN
        (* eliminate decimal point *)
        buf [3]  := buf [2] ;
        buf [2]  := buf [1] ;
        buf [1]  := bsp_c1;
        ppos := ppos + 1;
        END;
    (*ENDIF*) 
    e_frac := mdesc.datalen - 1;
    difference := mdesc.datafrac - e_frac;
    d_pos := d_pos - difference;
    add_c2 (buf, e_pos + 3, difference);
    END;
(*ENDWITH*) 
END; (* shift_dpoint *)
 
(*------------------------------*) 
 
PROCEDURE
      add_c2 (
            VAR text : tsp00_C40;
            lpos     : tin_natural;
            inc      : integer);
 
VAR
      text_sign    : -1 .. +1;
      inc_sign     : -1 .. +1;
      sign_changed : boolean;
      count        : tin_natural;
      abs_inc      : tin_natural;
 
BEGIN
IF  inc <> 0
THEN
    BEGIN
    IF  text [lpos - 2 ] = minus_sign
    THEN
        text_sign := -1
    ELSE
        text_sign := +1;
    (*ENDIF*) 
    IF  inc < 0
    THEN
        inc_sign := -1
    ELSE
        inc_sign := +1;
    (*ENDIF*) 
    abs_inc := abs (inc);
    count := 0;
    sign_changed := false;
    REPEAT
        IF  inc_sign = text_sign
        THEN
            inc_abs_c2 (text, lpos)
        ELSE
            BEGIN
            dec_abs_c2 (text, lpos, sign_changed);
            IF  sign_changed
            THEN
                text_sign := - text_sign;
            (*ENDIF*) 
            END;
        (*ENDIF*) 
        count := count + 1;
    UNTIL
        count = abs_inc;
    (*ENDREPEAT*) 
    IF  sign_changed
    THEN
        IF  text_sign = -1
        THEN
            text [lpos - 2 ] := minus_sign
        ELSE
            text [lpos - 2 ] := plus_sign
        (*ENDIF*) 
    (*ENDIF*) 
    END;
(*ENDIF*) 
END; (* add_c2 *)
 
(*------------------------------*) 
 
PROCEDURE
      inc_abs_c2 (
            VAR text : tsp00_C40;
            lpos     : tin_natural);
 
BEGIN
IF  text [lpos ] <> '9'
THEN
    text [lpos ] := succ (text [lpos] )
ELSE
    BEGIN
    text [lpos ] := zero;
    text [lpos - 1 ] := succ (text [lpos - 1] );
    END;
(*ENDIF*) 
END; (* inc_abs_c2 *)
 
(*------------------------------*) 
 
PROCEDURE
      dec_abs_c2 (
            VAR text         : tsp00_C40;
            lpos             : tin_natural;
            VAR sign_changed : boolean);
 
BEGIN
IF  text [lpos ] <> zero
THEN
    text [lpos ] := pred (text [lpos] )
ELSE
    IF  text [lpos - 1 ] <> zero
    THEN
        BEGIN
        text [lpos ] := '9';
        text [lpos - 1 ] := pred (text [lpos - 1] );
        END
    ELSE
        BEGIN
        sign_changed := true;
        text [lpos ] := '1';
        END;
    (*ENDIF*) 
(*ENDIF*) 
END; (* dec_abs_c2 *)
 
(*------------------------------*) 
 
PROCEDURE
      write_number (
            VAR nstring     : number_string;
            VAR mdesc       : mask_descriptor;
            VAR w_string    : internal_mask;
            VAR outputfield : tin_c250;
            VAR outputlen   : tin_natural;
            VAR err         : tin_mk_w_error);
 
BEGIN
code_interpreter (nstring, mdesc, w_string, err);
WITH w_string DO
    BEGIN
    outputlen := ppos;
    s10mv (250,250,
          @buf,1,
          @outputfield,1,outputlen);
    END;
(*ENDWITH*) 
END; (* write_number *)
 
(*------------------------------*) 
 
PROCEDURE
      code_interpreter (
            VAR nstring  : number_string;
            VAR mdesc    : mask_descriptor;
            VAR w_string : internal_mask;
            VAR err      : tin_mk_w_error);
 
VAR
      act_byte  : char;
      wstat     : wrdig_status;
      float_pos : mask_pos;
 
BEGIN
wstat     := number_not_started;
float_pos := 0;
WITH w_string DO
    BEGIN
    ppos := 0;
    WHILE (ppos < len) DO
        BEGIN
        ppos := ppos + 1;
        act_byte := buf [ppos] ;
        IF  ord (act_byte) > max_fieldtype
        THEN
            ci_case_text (w_string, wstat)
        ELSE
            CASE ord (act_byte) OF
                sign_opt, sign_obl, sign_credit, sign_debit:
                    ci_case_sign (w_string, nstring);
                e_char1, e_char2, one_edigit:
                    ci_case_expo (w_string, nstring, err);
                OTHERWISE:
                    ci_case_digit (w_string, wstat, float_pos,
                          nstring, mdesc, err);
                END;
            (*ENDCASE*) 
        (*ENDIF*) 
        END;
    (*ENDWHILE*) 
    END;
(*ENDWITH*) 
END; (* code_interpreter *)
 
(*------------------------------*) 
 
PROCEDURE
      ci_case_text (
            VAR w_string : internal_mask;
            wstat        : wrdig_status);
 
BEGIN
IF  wstat = number_started
THEN
    WITH w_string DO
        buf [ppos ] := bsp_c1;
    (*ENDWITH*) 
(*ENDIF*) 
END; (* ci_case_text *)
 
(*------------------------------*) 
 
PROCEDURE
      ci_case_digit (
            VAR w_string   : internal_mask;
            VAR wstat      : wrdig_status;
            VAR float_pos  : mask_pos;
            VAR nstring    : number_string;
            VAR mdesc      : mask_descriptor;
            VAR err        : tin_mk_w_error);
 
VAR
      digit   : char;
      subtype : field_type;
 
BEGIN
WITH w_string DO
    BEGIN
    subtype := ord (buf [ppos] ) - number_field;
    IF  wstat = number_not_started
    THEN
        float_pos := ppos - 1;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
WITH nstring DO
    BEGIN
    ppos := ppos + 1;
    digit := buf [ppos] ;
    IF  (ppos = d_pos) AND (mdesc.dtype = rds_fixed)
    THEN
        ppos := ppos + 1;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
IF  subtype = sign_or_zero
THEN
    WITH nstring DO
        IF  sign = minus_sign
        THEN
            digit := sign
        ELSE
            subtype := leading_zero;
        (*ENDIF*) 
    (*ENDWITH*) 
(*ENDIF*) 
IF  digit = bsp_c1
THEN
    CASE subtype OF
        leading_zero:
            digit := zero;
        number_protected, protect_or_sign:
            digit := protect_char;
        OTHERWISE:
        END
    (*ENDCASE*) 
ELSE
    IF  digit = minus_sign
    THEN
        CASE subtype OF
            lead_blanks, floating_text:
                digit := bsp_c1;
            leading_zero:
                digit := zero;
            number_protected:
                digit := protect_char;
            OTHERWISE:
            END
        (*ENDCASE*) 
    ELSE
        IF  (subtype IN [ lead_blanks_or_sign, float_or_sign,
            protect_or_sign, sign_or_zero] )
            AND (nstring.sign = minus_sign)
            AND (wstat = number_not_started)
        THEN
            BEGIN
            digit := overflow_char;
            WITH nstring DO
                SAPDB_PascalForcedFill (40, @buf, 1, 40, overflow_char);
            (*ENDWITH*) 
            err := mk_ill_var;
            END;
        (*ENDIF*) 
    (*ENDIF*) 
(*ENDIF*) 
IF  digit = bsp_c1
THEN
    wstat := number_started
ELSE
    BEGIN
    IF  (wstat <> digits_started)
        AND (subtype IN [ floating_text, float_or_sign] )
    THEN
        float_text (w_string, float_pos);
    (*ENDIF*) 
    wstat := digits_started;
    END;
(*ENDIF*) 
WITH w_string DO
    buf [ppos ] := digit;
(*ENDWITH*) 
END; (* ci_case_digit *)
 
(*------------------------------*) 
 
PROCEDURE
      float_text (
            VAR w_string  : internal_mask;
            VAR float_pos : mask_pos);
 
VAR
      old_pos : tin_natural;
      new_pos : mask_pos;
 
BEGIN
WITH w_string DO
    IF  float_pos < ppos - 1
    THEN
        BEGIN
        new_pos := ppos;
        FOR old_pos := float_pos DOWNTO 1 DO
            BEGIN
            new_pos := new_pos - 1;
            buf [new_pos ] := buf [old_pos] ;
            buf [old_pos ] := bsp_c1;
            END;
        (*ENDFOR*) 
        END;
    (*ENDIF*) 
(*ENDWITH*) 
END; (* float_text *)
 
(*------------------------------*) 
 
PROCEDURE
      ci_case_sign (
            VAR w_string : internal_mask;
            VAR nstring  : number_string);
 
VAR
      sign_char : char;
 
BEGIN
WITH nstring DO
    sign_char := sign;
(*ENDWITH*) 
WITH w_string DO
    BEGIN
    IF  (sign_char = plus_sign) AND (ord (buf [ppos] ) = sign_opt)
    THEN
        sign_char := bsp_c1;
    (*ENDIF*) 
    IF  ord (buf [ppos] ) in [ sign_credit, sign_debit ]
    THEN
        BEGIN
        IF  sign_char = plus_sign
        THEN
            buf [ppos ] := bsp_c1
        ELSE
            IF  ord (buf [ppos] ) = sign_credit
            THEN
                buf [ppos ] := 'C'
            ELSE
                buf [ppos ] := 'D';
            (*ENDIF*) 
        (*ENDIF*) 
        ppos := ppos + 1;
        IF  sign_char = plus_sign
        THEN
            buf [ppos ] := bsp_c1
        ELSE
            IF  ord (buf [ppos] ) = sign_credit
            THEN
                buf [ppos ] := 'R'
            ELSE
                buf [ppos ] := 'B';
            (*ENDIF*) 
        (*ENDIF*) 
        END
    ELSE
        buf [ppos ] := sign_char;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* ci_case_sign *)
 
(*------------------------------*) 
 
PROCEDURE
      ci_case_expo (
            VAR w_string : internal_mask;
            VAR nstring  : number_string;
            VAR err      : tin_mk_w_error);
 
VAR
      act_byte : char;
      digit : char;
 
BEGIN
WITH w_string DO
    act_byte := buf [ppos] ;
(*ENDWITH*) 
WITH nstring DO
    IF  ord (act_byte) = one_edigit
    THEN
        BEGIN
        ppos := ppos + 1;
        IF  buf [ppos ] <> zero
        THEN
            BEGIN
            digit := overflow_char;
            err := mk_ill_var;
            END
        ELSE
            BEGIN
            ppos := ppos + 1;
            digit := buf [ppos] ;
            END;
        (*ENDIF*) 
        END
    ELSE
        BEGIN
        IF  ord (act_byte) = e_char1
        THEN
            digit := expo_char1
        ELSE
            digit := expo_char2;
        (*ENDIF*) 
        ppos := e_pos;
        END;
    (*ENDIF*) 
(*ENDWITH*) 
WITH w_string DO
    buf [ppos ] := digit;
(*ENDWITH*) 
END; (* ci_case_expo *)
 
(*------------------------------*) 
 
PROCEDURE
      i40standardmask (
            dlen        : tin_natural;
            dfrac       : integer;
            dec         : tsp_decimal_presentation;
            VAR mask    : tin_c250;
            maxlen      : tin_natural;
            VAR act_len : tin_natural;
            VAR error   : tin_mk_p_error);
 
VAR
      mdesc : mask_descriptor;
      omask : internal_mask;
 
BEGIN
check_dtype (dlen, dfrac, error);
IF  error = mk_ok
THEN
    BEGIN
    set_mdesc (dlen, dfrac, mdesc);
    check_length (mdesc, dec, maxlen, error);
    END;
(*ENDIF*) 
IF  error = mk_ok
THEN
    BEGIN
    put_mdesc (mdesc, omask);
    (*
          *)
    standard_mask (mdesc, dec, omask);
    (*
          *)
    WITH omask DO
        BEGIN
        act_len := ppos;
        s10mv (250,maxlen,
              @buf,1,
              @mask,1,act_len);
        END;
    (*ENDWITH*) 
    END;
(*ENDIF*) 
END; (* i40standardmask *)
 
(*------------------------------*) 
 
PROCEDURE
      check_dtype (
            datalen   : tin_natural;
            datafrac  : integer;
            VAR error : tin_mk_p_error);
 
VAR
      ok : boolean;
 
BEGIN
ok := true;
IF  datalen > maxdigitnumber
THEN
    ok := false
ELSE
    IF  datalen = 0
    THEN
        ok := false;
    (*ENDIF*) 
(*ENDIF*) 
IF  error = mk_ok
THEN
    IF  datafrac > datalen
    THEN
        ok := false
    ELSE
        IF  (datafrac < 0 ) AND (datafrac <> csp_float_frac)
        THEN
            ok := false;
        (*ENDIF*) 
    (*ENDIF*) 
(*ENDIF*) 
IF  ok
THEN
    error := mk_ok
ELSE
    error := wrong_digitnumber;
(*ENDIF*) 
END; (* check_dtype *)
 
(*------------------------------*) 
 
PROCEDURE
      set_mdesc (
            dlen      : tin_natural;
            dfrac     : integer;
            VAR mdesc : mask_descriptor);
 
BEGIN
WITH mdesc DO
    BEGIN
    IF  dfrac = csp_float_frac
    THEN
        dtype := rds_float
    ELSE
        dtype := rds_fixed;
    (*ENDIF*) 
    datalen := dlen;
    IF  dtype = rds_float
    THEN
        datafrac := datalen - 1
    ELSE
        BEGIN
        datafrac := dfrac;
        IF  datalen = datafrac
        THEN
            datalen := datalen + 1;
        (*ENDIF*) 
        END;
    (*ENDIF*) 
    END;
(*ENDWITH*) 
END; (* set_mdesc *)
 
(*------------------------------*) 
 
PROCEDURE
      check_length (
            VAR mdesc : mask_descriptor;
            dec       : tsp_decimal_presentation;
            maxlen    : tin_natural;
            VAR error : tin_mk_p_error);
 
VAR
      length : tin_natural;
 
BEGIN
length := l_maskheader + 1
      + vorkommalen (mdesc, dec) + nachkommalen (mdesc);
IF  length > maxlen
THEN
    error := mask_too_long
ELSE
    error := mk_ok;
(*ENDIF*) 
END; (* check_length *)
 
(*------------------------------*) 
 
FUNCTION
      vorkommalen (
            VAR mdesc : mask_descriptor;
            dec       : tsp_decimal_presentation) : tin_natural;
 
VAR
      v_anz       : tin_natural;
      length      : tin_natural;
      nr_groups   : tin_natural;
 
BEGIN
WITH mdesc DO
    v_anz := datalen - datafrac;
(*ENDWITH*) 
IF  v_anz = 0
THEN
    length := 1
ELSE
    BEGIN
    length := v_anz;
    nr_groups := (v_anz - 1) DIV 3;
    IF  dec.thousand_token <> 'N'
    THEN
        length := length + nr_groups;
    (*ENDIF*) 
    END;
(*ENDIF*) 
vorkommalen := length;
END; (* vorkommalen *)
 
(*------------------------------*) 
 
FUNCTION
      nachkommalen (
            VAR mdesc : mask_descriptor) : tin_natural;
 
VAR
      length : tin_natural;
 
BEGIN
WITH mdesc DO
    BEGIN
    length := datafrac;
    IF  datafrac > 0
    THEN
        length := length + 1; (* Dezimalpunkt *)
    (*ENDIF*) 
    IF  dtype = rds_float
    THEN
        length := length + 4 (* E+99 *)
    (*ENDIF*) 
    END;
(*ENDWITH*) 
nachkommalen := length;
END; (* nachkommalen *)
 
(*------------------------------*) 
 
PROCEDURE
      standard_mask (
            VAR mdesc : mask_descriptor;
            dec       : tsp_decimal_presentation;
            VAR omask : internal_mask);
 
BEGIN
std_sign(omask);
std_vorkomma (mdesc, dec, omask);
std_nachkomma (mdesc, dec, omask);
IF  mdesc.dtype = rds_float
THEN
    std_edigs (omask);
(*ENDIF*) 
END; (* standard_mask *)
 
(*------------------------------*) 
 
PROCEDURE
      std_sign (
            VAR omask : internal_mask);
 
BEGIN
WITH omask DO
    BEGIN
    ppos := ppos + 1;
    buf [ppos ] := chr (sign_opt);
    END;
(*ENDWITH*) 
END; (* std_sign *)
 
(*------------------------------*) 
 
PROCEDURE
      std_vorkomma (
            VAR mdesc : mask_descriptor;
            dec       : tsp_decimal_presentation;
            VAR omask : internal_mask);
 
VAR
      group_len   : tin_natural;
      v_anz       : tin_natural;
      nr_groups   : tin_natural;
      number_ft   : field_type;
      count       : tin_natural;
      group_count : tin_natural;
 
BEGIN
WITH mdesc DO
    v_anz := datalen - datafrac;
(*ENDWITH*) 
WITH omask DO
    IF  v_anz = 0
    THEN
        BEGIN
        ppos := ppos + 1;
        buf [ppos ] := zero;
        END
    ELSE
        BEGIN
        group_len := v_anz MOD 3;
        nr_groups := (v_anz DIV 3) + 1;
        number_ft := number_field + floating_text;
        FOR group_count := 1 TO nr_groups DO
            BEGIN
            IF  group_len > 0
            THEN
                BEGIN
                FOR count := 1 TO group_len DO
                    BEGIN
                    ppos := ppos + 1;
                    buf [ppos ] := chr (number_ft);
                    END;
                (*ENDFOR*) 
                IF  group_count < nr_groups
                THEN
                    IF  dec.thousand_token <> 'N'
                    THEN
                        BEGIN
                        ppos := ppos + 1;
                        buf [ppos ] := dec.thousand_token;
                        END;
                    (*ENDIF*) 
                (*ENDIF*) 
                END;
            (*ENDIF*) 
            group_len := 3;
            END;
        (*ENDFOR*) 
        END;
    (*ENDIF*) 
(*ENDWITH*) 
END; (* std_vorkomma *)
 
(*------------------------------*) 
 
PROCEDURE
      std_nachkomma (
            VAR mdesc : mask_descriptor;
            dec       : tsp_decimal_presentation;
            VAR omask : internal_mask);
 
VAR
      count : tin_natural;
 
BEGIN
IF  mdesc.datafrac > 0
THEN
    WITH omask DO
        BEGIN
        ppos := ppos + 1;
        IF  mdesc.dtype = rds_float
        THEN
            buf [ppos ] := point_char
        ELSE
            buf [ppos ] := dec.zero_point;
        (*ENDIF*) 
        FOR count := 1 TO mdesc.datafrac DO
            BEGIN
            ppos := ppos + 1;
            buf [ppos ] := chr (number_field);
            END;
        (*ENDFOR*) 
        END;
    (*ENDWITH*) 
(*ENDIF*) 
END; (* std_nachkomma *)
 
(*------------------------------*) 
 
PROCEDURE
      std_edigs (
            VAR omask : internal_mask);
 
CONST
      edigits_plus_sign = 3;
 
VAR
      count : tin_natural;
 
BEGIN
WITH omask DO
    BEGIN
    ppos := ppos + 1;
    buf [ppos ] := chr(e_char1);
    FOR count := 1 TO edigits_plus_sign DO
        BEGIN
        ppos := ppos + 1;
        buf [ppos ] := chr (number_field);
        END;
    (*ENDFOR*) 
    END;
(*ENDWITH*) 
END; (* std_edigs *)
 
.CM *-END-* code ----------------------------------------
.SP 2 
***********************************************************
.PA 
