home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols000 / vol021 / rdr.pas < prev    next >
Pascal/Delphi Source File  |  1984-04-29  |  6KB  |  281 lines
  1. (*
  2. ** PROGRAM TITLE:    Alpha Numeric Numbers Conversions
  3. **
  4. ** WRITTEN BY:        Raymond E. Penley
  5. ** DATE WRITTEN:    5 July 1980
  6. **
  7. ** SUMMARY:
  8. **
  9. **    VAL =  Single character to integer value.
  10. **    RDR =  Alphanumeric to real number.
  11. **    STR =  Integer to alphanumeric.
  12. **
  13. **  Donated to PASCAL/Z USERS GROUP, July 1980
  14. **
  15. *)
  16. const    default = 80;        { Default length }
  17.  
  18. type    Dstring = STRING default;
  19.     str0    = STRING 0;
  20.     str255  = STRING 255;
  21.  
  22. var    zx :real;        { the real numbers go here }
  23.     done: boolean;
  24.     number : integer;    { the integer number in here }
  25.     answer : Dstring;    { String buffer        }
  26.  
  27. function length(x: str255): integer; external;
  28. procedure setlength(var x: str0; y: integer); external;
  29.  
  30. (*------------------------------------------*)
  31. Function VAL(ch: char): integer;
  32. { Returns the integer value of
  33.   the single char passed }
  34. const    z = 48; {  ORD('0')  }
  35. begin
  36.   VAL := ORD(ch) - z
  37. end;
  38.  
  39. (*------------------------------------------*)
  40. Function RDR(var f: Dstring  ): real;
  41. { read real numbers in free format.
  42.   author: Niklaus Wirth
  43.   book:   Pascal User Manual & Report
  44.       pg 122-123
  45.   ENTER WITH:
  46.     f = a string containing ONLY the alphanumeric number
  47.         to be converted to a real number.
  48.   RETURNS:
  49.     A real number.
  50.     Any error returns RDR := 0.0
  51. *}
  52. label    9;{ error exit }
  53. const
  54.     t48 = 281474976710656.0 ;
  55.     limit = 56294995342131.0 ;
  56.     lim1 = 322;        { maximum exponent }
  57.     lim2 = -292;        { minimum exponent }
  58.     space = ' ';
  59.     emsg1 = '**digit expected';
  60.     emsg2 = '**number too large';
  61. type
  62.     posint = 0..323;
  63. var
  64.   ch    : char;
  65.   y    : real;
  66.   posn,
  67.   a,i,e    : integer;
  68.   fatal,
  69.   s,ss    : boolean; { signs }
  70.  
  71. procedure Getc(var ch: char);
  72. begin
  73.   posn := posn + 1;
  74.   ch := f[posn];
  75. end;
  76.  
  77. function TEN(e: posint): real; {  = 10**e,  0<e<322  }
  78. var    i: integer;
  79.     t: real;
  80. begin
  81.   i := 0;
  82.   t := 1.0;
  83.   repeat
  84.     If ODD(e) then
  85.       case i of
  86.     0: t := t * 1.0E1;
  87.     1: t := t * 1.0E2;
  88.     2: t := t * 1.0E4;
  89.     3: t := t * 1.0E8;
  90.     4: t := t * 1.0E16;
  91.     5: t := t * 1.0E32    { that's all! }
  92.     6,7,8:
  93.        begin
  94.        writeln('**Floating point overflow');
  95.        fatal := true;
  96.        e := 2;{ sets e to zero on next division }
  97.        end;
  98.     {*===================*
  99.     --- can not use ---
  100.      6: t := t * 1.0E64;
  101.      7: t := t * 1.0E128;
  102.      8: t := t * 1.0E256
  103.      *===================*}
  104.       end{ case };
  105.     e := e DIV 2;
  106.     i := i + 1;
  107.   until e=0;
  108.   TEN := t;
  109. end{of TEN};
  110.  
  111. begin
  112.   fatal := false;
  113.   posn := length(f);
  114.   setlength(f,posn+1);
  115.   f[posn+1] := space;
  116.   posn := 0;
  117.   getc(ch);
  118.   { skip leading blanks }
  119.   While ch=space do getc(ch);
  120.   If ch='-' then
  121.     begin
  122.     s := true;
  123.     getc(ch)
  124.     end
  125.   Else
  126.     begin
  127.     s := false;
  128.     If ch='+' then getc(ch)
  129.     end;
  130.   If not(ch IN ['0'..'9']) then
  131.     begin
  132.     writeln(emsg1);
  133.     {HALT} fatal := true; goto 9;
  134.     end;
  135.   a := 0;
  136.   e := 0;
  137.   repeat
  138.     If a<limit then
  139.       a := 10 * a + VAL(ch)
  140.     Else
  141.       e := e+1;
  142.     getc(ch);
  143.   until not(ch IN ['0'..'9']);
  144.   If ch='.' then
  145.     begin { read fraction }
  146.     getc(ch);
  147.     while ch IN ['0'..'9'] do
  148.       begin
  149.       If a<limit then
  150.     begin
  151.     a := 10 * a + VAL(ch);
  152.     e := e - 1
  153.     end;
  154.       getc(ch);
  155.       end{ while };
  156.     end{ read fraction };
  157.   If (ch='E') or (CH='e') then
  158.     begin { read scale factor }
  159.       getc(ch);
  160.       i := 0;
  161.       If ch='-' then
  162.         begin ss := true; getc(ch) end
  163.       Else
  164.         begin
  165.         ss := false;
  166.         If ch='+' then getc(ch)
  167.         end;
  168.       If ch IN ['0'..'9'] then
  169.         begin
  170.         i := VAL(ch);
  171.         getc(ch);
  172.         while ch IN ['0'..'9'] do
  173.       begin
  174.       If i<limit then i := 10 * i + VAL(ch);
  175.       getc(ch)
  176.       end{ while}
  177.         end{ If }
  178.       Else
  179.         begin
  180.         writeln(emsg1);
  181.         {HALT} fatal := true; goto 9;
  182.         end;
  183.       If ss
  184.      then e := e - i
  185.      Else e := e + i;
  186.     end{ read scale factor };
  187.   If e < lim2 then
  188.     begin
  189.     a := 0;
  190.     e := 0;
  191.     end
  192.   Else
  193.     If e > lim1 then
  194.       begin
  195.       writeln(emsg2);
  196.       {HALT} fatal := true; goto 9;
  197.       end;
  198.   {  0 < a < 2**49  }
  199.   If a >= t48 then
  200.     y := ((a+1) DIV 2) * 2.0
  201.   Else
  202.     y := a;
  203.   If s then y := -y;
  204.   If e < 0 then
  205.     RDR := y/TEN(-e)
  206.   Else
  207.     If e<>0 then
  208.       RDR := y*TEN(e)
  209.     Else
  210.       RDR := y;
  211. 9: If fatal then RDR := 0.0;
  212. End{of RDR};
  213.  
  214. (*------------------------------------------*)
  215. Procedure STR( var S: Dstring;
  216.         tval: integer );
  217. { ENTER WITH:
  218.     tval = INTEGER to be converted to an alphanumeric
  219.            string.
  220.   RETURNS:
  221.     An alphanumeric equal of tval in S.
  222. }
  223. const
  224.     size = 15; { number of digits in the number }
  225. var
  226.     cix : char;
  227.     digits : packed array[1..10] of char;
  228.     i,        { length of number }
  229.     d,t,j: integer;
  230. begin
  231.   digits := '0123456789';
  232.   t := ABS(tval);
  233.   setlength(S,0);    { null string }
  234.   i := 0;
  235.   repeat { generate digits }
  236.     i := i + 1;
  237.     d := t MOD 10;
  238.     append(S,digits[d+1]);
  239.     t := t DIV 10
  240.   until (t=0) OR (i>=size);
  241.   If (tval<0) AND (i<size) then
  242.     begin { sign }
  243.     i := i + 1;
  244.     append(S,'-')
  245.     end;
  246.   j := 1;
  247.   while j<i do
  248.     begin{ reverse }
  249.     cix := S[i]; S[i] := S[j]; S[j] := cix;
  250.     i := i - 1;
  251.     j := j + 1
  252.     end{ revese }
  253. End{of STR};
  254.  
  255. begin
  256.   done := false;
  257.   repeat
  258.     writeln;
  259.     write('Enter a number (real or integer) ?');
  260.     readln(answer);
  261.     writeln('literal number is ..... ', answer);
  262.     writeln('with a length of  ..... ', length(answer):4 );
  263.     zx := RDR(answer);
  264.     writeln('the numeric equal of your literal .. ', zx);
  265.     writeln('Formatted as ! Number:10:4 ! ....... ', zx:10:4);
  266.     write('Five times ', zx, ' = ');writeln( zx * 5 );
  267.     write('The integer portion is ............... ');writeln( trunc(zx) );
  268.     writeln;
  269.     write('Enter an integer ?');
  270.     readln(number);
  271.     STR(answer, number);
  272.     writeln('The integer number is .............. ', number);
  273.     writeln('Expressed as an alphanumeric is .... ', answer);
  274.     writeln('the length of the literal is ....... ', length(answer) );
  275.     append(answer,answer);
  276.     writeln('Since we now have a string');
  277.     writeln(' we can concatenate like so ........ ', answer);
  278.   Until done;
  279. End{ of Alpha_Numeric }.
  280.  
  281.