Oakland CPM Archive/oakcpm.iso/sigm/vol134/paszcode.rn$

Text File | 1984-04-29 | 9.3 KB | 278 lines

PROCEDURE rnsetup;                                              {$e-r-}

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* To be executed once, at the start of a run, to set up tables      *}
{* for subsequent use by the RN$ function.                           *}
{*                                                                   *}
{* Requires the following global definitions:                        *}
{*    CONST:  rnleft, rnmax                                          *}
{*    TYP:    rndex, rnpair                                          *}
{*    VAR:    rnset, rnlimit, rnmin                                  *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

VAR
    i : rndex;
    v : rnpair;

BEGIN {rnsetup procedure}
    v[1] := 1.0;
    v[2] := 5.0;
    FOR i := rnleft DOWNTO 1 DO
      BEGIN {for}
        rnset[i] := v;
        v[1] := v[1] * 10.0;
        v[2] := v[2] * 10.0
      END;  {for}
    rnlimit := v[1];

    v[1] := 0.1;
    v[2] := 0.5;
    FOR i := (rnleft+1) TO rnmax DO
      BEGIN {for}
        rnset[i] := v;
        v[1] := v[1] / 10.0;
        v[2] := v[2] / 10.0
      END;  {for}
    rnmin := v[2]
END;  {rnsetup procedure} {$L+}
FUNCTION strtoreal (given: longstr): real;                      {$e-r-}

    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    {* Given a string containing an alleged real number in external  *}
    {* decimal form, return its value as a real, with grerror=false. *}
    {* If the given value is not valid, return 0.0, grerror=true.    *}
    {*                                                               *}
    {* Validity criteria:                                            *}
    {*                                                               *}
    {*    1.  First non-blank may be a hyphen (for negative number). *}
    {*                                                               *}
    {*    2.  Beginning with first non-blank (or character after     *}
    {*        leading hyphen, if any), each character must be a      *}
    {*        numeral, a comma, or a period.                         *}
    {*                                                               *}
    {*    3.  Only numerals are permitted to the right of the        *}
    {*        (first) period.                                        *}
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

CONST
    comma    = ',';
    decimal  = '.';
    hyphen   = '-';
    blank1   = ' ';
VAR
    i, j     : 1..longlength;
    addend   : real;
    pastdec  : boolean;
    negsign  : boolean;
    result   : real;
    units    : real;
{$L+}
BEGIN {strtoreal function}
    result  := 0;
    pastdec := FALSE;
    grerror := FALSE;
    j := 1;
    WHILE given[j]=blank1 DO
      j := j + 1;
    IF given[j]=hyphen
      THEN
        BEGIN {then}
          negsign := TRUE;
          j := j + 1
        END   {then}
      ELSE negsign := false;
    FOR i := j TO length(given) DO
        IF given[i] IN ['0'..'9']
          THEN
            BEGIN {then}
              addend := ORD(given[i]) - ORD('0');
              IF pastdec
                THEN
                  BEGIN {then}
                    result := result + (addend*units);
                    units  := units / 10.0
                  END   {then}
                ELSE result := (result * 10.0) + addend
            END   {then}
        ELSE
          IF ((given[i]=decimal) AND (NOT pastdec))
            THEN
              BEGIN {then}
                pastdec := TRUE;
                units   := 0.1
              END   {then}
        ELSE
          IF ((given[i]<>comma) OR (pastdec))
            THEN grerror := TRUE;
    IF grerror
      THEN strtoreal := 0.0
      ELSE
        IF negsign
          THEN strtoreal := -result
          ELSE strtoreal := result
END;  {strtoreal function} {$L+}
FUNCTION rn$ (given: REAL;  retntype: rn$ind): rnstr;  {$C-R+}

{** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **}
{* Given a real number, return a "display" representation of that   *}
{* number, punctuated with commas, decimal point and (if number is  *}
{* negative) leading hyphen.  Leading zeroes are suppressed.        *}
{* Precision is specified by global constants RNLEFT and RNRIGHT.   *}
{* If the second parameter = 'FULL', the returned field will be     *}
{* fixed-length (RNLEN), with leading blanks as required;  if       *}
{* "COMPACT", leading blanks will be removed, and the field may be  *}
{* shorter.                                                         *}
{*                                                                  *}
{* If the given number's absolute value is too large to be respre-  *}
{* sented with rnleft positions to the left of the decimal point,   *}
{* a value of all nines (punctuated, and with leading hyphen if     *}
{* appropriate) is returned.                                        *}
{*                                                                  *}
{* External definitions required:                                   *}
{*   CONST     RNLEFT, RNRIGHT, RNMAX - define precision            *}
{*             RNLEN    - length of maximum-size string field       *}
{*   TYPE      RN$IND   - (full, compact)                           *}
{*             RNSTR    - STRING                                    *}
{*             RNDEX    - 0..RNMAX                                  *}
{*             RNLENDX  -                                           *}
{*   VAR       RNSET    - array initialized by RNSETUP              *}
{*   PROCEDURE SETLENGTH - Pascal/Z string procedure                *}
{*********************************************************************}
{**                         COPYRIGHT NOTICE                        **}
{**    Copyright (C) 1981, 1982 by Systems Engineering Associates   **}
{**                    124 West Blithedale Avenue                   **}
{**                 Mill Valley, California  U.S.A.                 **}
{**                                                                 **}
{**  Permission is hereby given to all parties to copy or to adapt  **}
{**   this Function, provided that the full text of this Copyright  **}
{**       Notice is included in each such copy or adaptation.       **}
{*********************************************************************}

CONST
    hyphen = '-';
    comma   = ',';
    decimal = '.';
    space   = ' ';
    zero    = '0';
    five    = '5';
    nine    = '9';
VAR
    i        : rndex;
    work     : REAL;
    numeral  : CHAR;
    startsig : rnlendx;
    ptr      : rnlendx;
    shortrn$ : rnstr;
    result   : rnstr;
{$L+}
PROCEDURE rn$mask (xleft, xright : rndex);  {$C-R-}

VAR
    i        : rnlendx;

BEGIN {rn$mask procedure}
    result := space;
    FOR i := 1 TO xleft DO
      BEGIN {for}
        append(result,space);
        IF ((((xleft-i) MOD 3)=0) AND (i<xleft))
          THEN append(result,comma)
      END;  {for}
    append(result,decimal);
    FOR i := 1 TO xright DO
      append(result,space)
END;  {rn$mask procedure}


{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }


PROCEDURE rn$nines;

BEGIN {rn$nines procedure}
    startsig := ptr;
    WHILE ptr<rnlen DO
      BEGIN {while}
        IF result[ptr]=space
          THEN result[ptr] := nine;
        IF ptr<rnlen
          THEN ptr := ptr+1
      END   {while}
END;  {rn$nines procedure} {$L+}
PROCEDURE rn$trans;

VAR
    i     : rndex;
    basis : 0..255;

BEGIN {rn$trans procedure}
    FOR i := 1 TO rnmax DO
      BEGIN {for}
        WHILE result[ptr]<>space DO
          BEGIN {while}
            IF startsig=0
              THEN
                CASE result[ptr] OF
                    comma  :  result[ptr] := space;
                    decimal:  BEGIN {decimal}
                                startsig := ptr-1;
                                result[startsig] := zero
                              END   {decimal}
                  END; {case}
            ptr := ptr + 1
          END;  {while}
        IF work<rnset[i,1]
          THEN
            IF startsig>0
              THEN result[ptr] := zero
              ELSE {no action}
          ELSE
            BEGIN
              IF startsig=0
                 THEN startsig := ptr;
              IF work<rnset[i,2]
                THEN basis := ORD(zero)
                ELSE
                  BEGIN
                    work  := work - rnset[i,2];
                    basis := ORD(five)
                  END;  {else}
              WHILE work>=rnset[i,1] DO
                BEGIN {while}
                  work := work - rnset[i,1];
                  basis := basis + 1
                END;  {while}
              result[ptr] := CHR(basis)
            END; {else}
        IF ptr<rnlen
          THEN ptr := ptr+1
      END   {for}
END;  {rn$trans procedure} {$L+}
BEGIN {rn$ function} {$C-R+}
    rn$mask(rnleft,rnright);
    IF given<0.0
      THEN work := -given + rnmin
      ELSE work :=  given + rnmin;
    startsig := 0;
    ptr      := 2;

    IF work<rnlimit
      THEN rn$trans
      ELSE rn$nines;
    IF given<0.0
      THEN
        BEGIN {then}
          startsig := startsig - 1;
          result[startsig] := hyphen
        END;  {then}
    IF retntype=full
      THEN rn$ := result
      ELSE
        BEGIN
          setlength(shortrn$,0);
          FOR ptr := startsig TO rnlen DO
            append(shortrn$,result[ptr]);
          rn$ := shortrn$
        END   {else}
END;  {rn$ function} {$L+}