head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.20.42;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.01.16;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.40.09;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.18.43;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.08.21.12.35.54;  author jwh;  state Exp;
branches ;
next     54.2;

54.2
date     91.08.21.09.47.16;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.24.06;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.25.17;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.09.00;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.08.24;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.23.28;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.07.47;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.13.42;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.10.54.52;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.41.34;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.48.56;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.06.38;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.13.57.30;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.42.05;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.25.04;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.47.30;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.32.05;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.23.38;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.36.30;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.15.12;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.28.29;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.03.42;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.37.07;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.44.27;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.05.34;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.43.08;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.27.39;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.10.55.42;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.25.04;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.13.02.47;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.22.08;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.09.39.49;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.10.16.35;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.10.59.40;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.13.44.48;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.10.57.53;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.13.59;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.15.09.46;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.25.26;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.15.38.14;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.10.55;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.15.12.26;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.24.30;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.14.07;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.09.39.50;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.10.47.27;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.14.23.51;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.11.44.44;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.13.33.46;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.17.43.57;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.16.30.41;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.19.36.55;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.11.46.32;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.31.51;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.14.27.05;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@$MODCAL,UCSD,sysprog,partial_eval,range off$
$iocheck off,ovflcheck off$

 program allrealstuff;
 module mfs;

	$copyright 'COPYRIGHT (C) 1982 BY HEWLETT-PACKARD COMPANY'$


import sysglobals,fs,sysdevs,misc,asm;

export

var

flpt_present['FLTPTHDW']: boolean;   {*** NOTE ABSOLUTE ADDRESS !!! }

procedure freadreal (var t: text; var x: real);
procedure fwritereal(var t: text; x: real; w,d: shortint);

procedure freadstrreal (var s: string255; var p2: integer; var x: real);
procedure fwritestrreal(var r: string;var p2: integer;x: real; w,d: shortint);

IMPLEMENT

  const
    nlen = 255;
  type
    stringnlen = string[nlen];
    sourcetype = (strg,phile);
    BCDdigit = 0..15; {0..9 are used}
    bcd_strtype = record
		    signbit: (pls,mnus);
		    mantissa: packed array[1..16] of BCDdigit;
		    exponent: shortint;
		  end;
  var
    nextchr: shortint;

procedure asm_bcd_real(s: bcd_strtype; x: real);
  external;


procedure inputreal(stype: sourcetype;
		    anyvar f: text;
		    fstrg: string255;
		    var number: stringnlen);

  label 1;
  const
    blank = ' ';
    backspace = chr(8);
    DEL = chr(127);
  var
    chr: char;
    firstchar,streof: boolean;
    nchars: shortint;

  procedure check_chr;
    var
      i: integer;
    begin
    if chr = DEL then
      if stype = phile then
	begin
	i := nchars;
	killchar(f,i);
	nchars := i;
	firstchar := true;
	escape(1);
	end
      else { stype = strg }
	nchars := 0
    else { chr = backspace }
      if stype = phile then
	begin
	i := nchars;
	killchar(f,i);
	nchars := i;
	firstchar := true;
	end
      else
	nchars := nchars - 1;
    end;

  procedure get1char;
    begin
    if nchars=nlen then escape(2);
      if stype = strg then
	begin
	nextchr := nextchr + 1;
	if nextchr > strlen(fstrg) then
	  if streof then escape(2)
	  else streof := true;
	if streof or (fstrg[nextchr]=eol) then
	  chr := blank
	else chr := fstrg[nextchr];
	end
      else {stype = phyle}
	begin
	if not firstchar then
	  get(f);
	firstchar := false;
	chr := f^;
	if ioresult <> ord(inoerror) then
	  escape(2);
	end;
    end; { get1char }

  procedure expodigit;
    { looking for <digit> }
    label 9;
    begin
    while true do
      begin
      get1char;
      if (chr >= '0') and (chr <= '9') then
	begin
	nchars := nchars + 1;
	number[nchars] := chr;
	end
      else
	begin
	if (chr = backspace) or (chr = DEL) then
	  begin
	  check_chr;
	  if ((number[nchars] < '0') or
	      (number[nchars] > '9')) then goto 9;
	  end
	else escape(3); {end of input}
	end;
      end;
  9:chr := number[nchars];
    end; { expodigit }

  procedure gotexposign;
    { looking for <digit> }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expodigit;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    goto 9;
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end; { gotexposign }

  procedure expostate;
    { looking for <digit>, '+', '-' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expodigit;
	  end
	else if (chr = '+') or (chr = '-') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  gotexposign;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    goto 9;
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end;

  procedure fracstate;
    { looking for <digit>, 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr = 'E') or (chr = 'e') or
	   (chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    if (number[nchars+1] = '.') then
	      goto 9;
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { fracstate }

  procedure mantissadigitA;
    { looking for <digit>, '.', 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then {ok}
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else if (chr = 'E') or (chr = 'e') or
		(chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { mantissadigitA }

  procedure mantissadigitB;
    { looking for <digit>, '.', 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then {ok}
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else if (chr = '.') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else if (chr = 'E') or (chr = 'e') or
		(chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if ((number[nchars] = '+') or
		(number[nchars] = '-')) then goto 9;
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { mantissadigitB }

  procedure gotmantissasign;
    { looking for <digit>, '.' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  mantissadigitB;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end;

  procedure startstate;
    { looking for '+', '-', '.', <digit> }
    begin
      nchars := 0;
      setstrlen(number,strmax(number));
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  mantissadigitA;
	  end
	else if (chr = '+') or (chr = '-') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  gotmantissasign;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    escape(1);
	    end
	  else if (chr <> blank) then
	    escape(2); { error }
	  end;
	end;
    end; { startstate }

  begin { inputreal }
    streof := false;
    firstchar := true;
1:  try
      startstate;
    recover
      if escapecode = 1 then goto 1
      else if escapecode = 2 then    { error }
	begin
	if ioresult = ord(inoerror) then
	  IORESULT := ord(IBADFORMAT);
	end
      else if escapecode = 3 then
	begin
	nchars := nchars + 1;
	number[nchars] := blank;
	end
      else escape(escapecode);
  end; { inputreal }

procedure getrealnumber(var number: stringnlen;
			var x: real);
  var
    bcd_str: bcd_strtype;
    mantissa_digit,i,expsign,
    nextchar,extraexponent: shortint;
    xvalid,decpnt,nonzero: boolean;
    ch: char;

  begin
    with bcd_str do
      begin
      xvalid := false;
      exponent := 0;       { 2's comp exponent }
      extraexponent := 0;  { amount of normalization }
      mantissa_digit := 1; { next digit to be inserted }
      signbit := pls;      { sign of real number }
      decpnt := false;     { have we seen a decimal point }
      nonzero := false;    { nonzero digit encountered }
      for i := 1 to 16 do mantissa[i] := 0;
      nextchar := 1;
      repeat
	ch := number[nextchar];
	nextchar := nextchar + 1;
      until (ch <> ' ');
      if (ch = '+') or (ch = '-') then
	begin
	if ch = '-' then signbit := mnus;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      while ch = '0' do
	begin
	xvalid := true;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      while (ch >= '0') and (ch <= '9') do
	begin
	nonzero := true;
	xvalid := true;
	if mantissa_digit <= 16 then
	  mantissa[mantissa_digit] := ord(ch) - ord('0');
	mantissa_digit := mantissa_digit + 1;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      if ch = '.' then
	begin
	extraexponent := mantissa_digit - 1;
	decpnt := true;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	while not nonzero and (ch = '0') do
	  begin
	  xvalid := true;
	  extraexponent := extraexponent - 1;
	  ch := number[nextchar];
	  nextchar := nextchar + 1;
	  end;
	while (ch >= '0') and (ch <= '9') do
	  begin
	  xvalid := true;
	  nonzero := true;
	  if mantissa_digit <= 16 then
	    mantissa[mantissa_digit] := ord(ch) - ord('0');
	  mantissa_digit := mantissa_digit + 1;
	  ch := number[nextchar];
	  nextchar := nextchar + 1;
	  end;
	end;
      if (ch in ['e','E','l','L']) and xvalid then
	begin
	ch := number[nextchar];
	nextchar := nextchar + 1;
	if ch in ['+','-','0'..'9'] then
	  begin
	  exponent := 0;
	  expsign := 1;
	  if (ch = '-') or (ch = '+')  then
	    begin
	    if ch = '-' then expsign := -1;
	    ch := number[nextchar];
	    nextchar := nextchar + 1;
	    end;
	  try
	    while (ch >= '0') and (ch <= '9') do
	      begin
	      exponent := exponent * 10 -
			  ord('0') + ord(ch);
	      ch := number[nextchar];
	      nextchar := nextchar + 1;
	      end;
	    exponent := exponent * expsign;
	  recover
	    if escapecode = -4 then  { intover }
	      xvalid := false
	    else escape(escapecode);
	  end
	else xvalid := false;
	end;
      if xvalid then
	if nonzero then
	  begin
	  if not decpnt then extraexponent := mantissa_digit - 1;
	  exponent := exponent + extraexponent;
	  try
	    asm_bcd_real(bcd_str,x);
	  recover
	    if escapecode = -20 then
	      escape(escapecode)
	    else
	      IORESULT := ord(IBADFORMAT);
	  end
	else x := 0.0
      else IORESULT := ord(IBADFORMAT);
      end;
  end; { getrealnumber }

procedure freadreal(var t: text; var x: real);
  var
    number: stringnlen;

  begin { freadreal }
  if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
  else begin                                                  { scs 1/17/83 }
       ioresult := ord(inoerror);
       if eof(t) then
	 ioresult := ord(ieof)
       else
	 inputreal(phile,t,'',number);
       if ioresult = ord(inoerror) then
	 getrealnumber(number,x);
       end;
  end; { freadreal }


procedure freadstrreal(var s: string255; var p2: integer; var x: real);
  var
    number: stringnlen;
    xxxxx: shortint;

  begin
  nextchr := 0;
  ioresult := ord(inoerror);
  if (p2<1) or (p2>strlen(s)) then
    ioresult := ord(istrovfl)
  else
    inputreal(strg,xxxxx,str(s,p2,strlen(s)-p2+1),number);
  if ioresult = ord(inoerror) then
    begin
    p2 := p2 + nextchr - 1;
    getrealnumber(number,x);
    end;
  end;

procedure asm_bcdround(bcd: bcd_strtype;
		       d: shortint;
		       var  s: string255);
		       external;
procedure asm_real_bcd(x: real; s: bcd_strtype);
  external;

procedure fwritestrreal (var r: string;
	var p2: integer; x: real; w,d: shortint);
  var
    bcd_str: bcd_strtype;
    s: string255;
    i,j,numdigits,minwidth: shortint;

  begin {fwritestrreal}
    ioresult := ord(inoerror);
    setstrlen(s,255);
    if x < 0 then
      begin
      minwidth := 9;
      x := -x;
      s[1] := '-';
      end
    else
      begin
      minwidth := 8;
      s[1] := ' ';
      end;
    if (d > 252) then d := -1;
    if w < 0 then w := 12;
    asm_real_bcd(x,bcd_str);
    with bcd_str do
      begin
      if x <> 0 then { mantissa between 1 and 10 }
	exponent := exponent - 1;
      if (d < 0) or (exponent >= 15) then
	begin
	if (w < minwidth) then w :=  minwidth;
	numdigits := w - (minwidth - 2)
	end
      else
	numdigits := d + exponent + 1;
      if numdigits < 0 then { number is 0.0 }
	begin
	s[1] := '0';
	s[2] := '.';
	if d > 0 then setstrlen(s,d+2)
		 else setstrlen(s,1);
	for j := 3 to strlen(s) do s[j] := '0';
	end
      else
	begin
	if numdigits > 15 then numdigits := 15;
	asm_bcdround(bcd_str,numdigits,s);
	if (d < 0) or (exponent >= 15) then
	  begin { scientific notation }
	  s[2] := s[3];
	  s[3] := '.';
	  j := numdigits + 3;
	  s[j] := 'E';
	  j := j + 1;
	  if exponent < 0 then
	    begin
	    s[j] := '-';
	    exponent := -exponent;
	    end
	  else s[j] := '+';
	  j := j + 1;
	  s[j] := chr(exponent DIV 100 + ord('0'));
	  j := j + 1;
	  s[j] := chr((exponent MOD 100) DIV 10
		  + ord('0'));
	  j := j + 1;
	  s[j] := chr(exponent MOD 10 + ord('0'));
	  setstrlen(s,j);
	  end
	else { fixed point notation }
	  if exponent >= 0 then
	    begin
	    for i := 2 to exponent + 2 do
	      s[i] := s[i+1];
	    s[3+exponent] := '.';
	    if d > 14 - exponent then
	      d := 14 - exponent;
	    if d = 0 then setstrlen(s,2+exponent)
		     else setstrlen(s,3+d+exponent);
	    end
	  else
	    begin
	    { numdigits may have changed }
	    numdigits := d + exponent + 1;
	    if numdigits > 14 then
	      numdigits := 14;
	    for i := numdigits+2 downto 3 do
	      s[i-exponent] := s[i];
	    s[2] := '0';
	    s[3] := '.';
	    fillchar(s[4],-exponent-1,'0');
	    if d > 14 then d := 14;
	    if d = 0 then setstrlen(s,2)
		     else setstrlen(s,3+d);
	    end;
	end;
      if s[1] = ' ' then {get rid of blank}
	begin
	moveleft(s[2],s[1],strlen(s)-1);
	setstrlen(s,strlen(s)-1);
	end;
      if w < strlen(s) then w := strlen(s);
      strwrite(r,p2,p2,s:w);
      end; { with bcd_str }
  end; { fwritestrreal }


procedure fwritereal
  (var t: text; x: real; w,d: shortint);
  var
    s: string255;
    dummy: integer;
  begin
  setstrlen(s,0);
  $range off$ strwrite(s,1,dummy,x:w:d);
  if ioresult = ord(inoerror) then
    fwritebytes(t,s[1],strlen(s));
  end;

end; { module mfs }

import mfs;

procedure asm_flpt_reset; external;


begin   { Code to initialize floating point hardware -- 10/26/83 jws }
  try
    flpt_present:=false;
    asm_flpt_reset;
    flpt_present:=true;
  recover
    if escapecode<>-12 { bus err}
      then escape(escapecode);
end. {more file support}

@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 694
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 694
$MODCAL,UCSD,sysprog,partial_eval,range off$
$iocheck off,ovflcheck off$

 program allrealstuff;
 module mfs;

	$copyright 'COPYRIGHT (C) 1982 BY HEWLETT-PACKARD COMPANY'$


import sysglobals,fs,sysdevs,misc,asm;

export

var

flpt_present['FLTPTHDW']: boolean;   {*** NOTE ABSOLUTE ADDRESS !!! }

procedure freadreal (var t: text; var x: real);
procedure fwritereal(var t: text; x: real; w,d: shortint);

procedure freadstrreal (var s: string255; var p2: integer; var x: real);
procedure fwritestrreal(var r: string;var p2: integer;x: real; w,d: shortint);

IMPLEMENT

  const
    nlen = 255;
  type
    stringnlen = string[nlen];
    sourcetype = (strg,phile);
    BCDdigit = 0..15; {0..9 are used}
    bcd_strtype = record
		    signbit: (pls,mnus);
		    mantissa: packed array[1..16] of BCDdigit;
		    exponent: shortint;
		  end;
  var
    nextchr: shortint;

procedure asm_bcd_real(s: bcd_strtype; x: real);
  external;


procedure inputreal(stype: sourcetype;
		    anyvar f: text;
		    fstrg: string255;
		    var number: stringnlen);

  label 1;
  const
    blank = ' ';
    backspace = chr(8);
    DEL = chr(127);
  var
    chr: char;
    firstchar,streof: boolean;
    nchars: shortint;

  procedure check_chr;
    var
      i: integer;
    begin
    if chr = DEL then
      if stype = phile then
	begin
	i := nchars;
	killchar(f,i);
	nchars := i;
	firstchar := true;
	escape(1);
	end
      else { stype = strg }
	nchars := 0
    else { chr = backspace }
      if stype = phile then
	begin
	i := nchars;
	killchar(f,i);
	nchars := i;
	firstchar := true;
	end
      else
	nchars := nchars - 1;
    end;

  procedure get1char;
    begin
    if nchars=nlen then escape(2);
      if stype = strg then
	begin
	nextchr := nextchr + 1;
	if nextchr > strlen(fstrg) then
	  if streof then escape(2)
	  else streof := true;
	if streof or (fstrg[nextchr]=eol) then
	  chr := blank
	else chr := fstrg[nextchr];
	end
      else {stype = phyle}
	begin
	if not firstchar then
	  get(f);
	firstchar := false;
	chr := f^;
	if ioresult <> ord(inoerror) then
	  escape(2);
	end;
    end; { get1char }

  procedure expodigit;
    { looking for <digit> }
    label 9;
    begin
    while true do
      begin
      get1char;
      if (chr >= '0') and (chr <= '9') then
	begin
	nchars := nchars + 1;
	number[nchars] := chr;
	end
      else
	begin
	if (chr = backspace) or (chr = DEL) then
	  begin
	  check_chr;
	  if ((number[nchars] < '0') or
	      (number[nchars] > '9')) then goto 9;
	  end
	else escape(3); {end of input}
	end;
      end;
  9:chr := number[nchars];
    end; { expodigit }

  procedure gotexposign;
    { looking for <digit> }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expodigit;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    goto 9;
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end; { gotexposign }

  procedure expostate;
    { looking for <digit>, '+', '-' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expodigit;
	  end
	else if (chr = '+') or (chr = '-') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  gotexposign;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    goto 9;
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end;

  procedure fracstate;
    { looking for <digit>, 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr = 'E') or (chr = 'e') or
	   (chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    if (number[nchars+1] = '.') then
	      goto 9;
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { fracstate }

  procedure mantissadigitA;
    { looking for <digit>, '.', 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then {ok}
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else if (chr = 'E') or (chr = 'e') or
		(chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { mantissadigitA }

  procedure mantissadigitB;
    { looking for <digit>, '.', 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then {ok}
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else if (chr = '.') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else if (chr = 'E') or (chr = 'e') or
		(chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if ((number[nchars] = '+') or
		(number[nchars] = '-')) then goto 9;
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { mantissadigitB }

  procedure gotmantissasign;
    { looking for <digit>, '.' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  mantissadigitB;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end;

  procedure startstate;
    { looking for '+', '-', '.', <digit> }
    begin
      nchars := 0;
      setstrlen(number,strmax(number));
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  mantissadigitA;
	  end
	else if (chr = '+') or (chr = '-') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  gotmantissasign;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    escape(1);
	    end
	  else if (chr <> blank) then
	    escape(2); { error }
	  end;
	end;
    end; { startstate }

  begin { inputreal }
    streof := false;
    firstchar := true;
1:  try
      startstate;
    recover
      if escapecode = 1 then goto 1
      else if escapecode = 2 then    { error }
	begin
	if ioresult = ord(inoerror) then
	  IORESULT := ord(IBADFORMAT);
	end
      else if escapecode = 3 then
	begin
	nchars := nchars + 1;
	number[nchars] := blank;
	end
      else escape(escapecode);
  end; { inputreal }

procedure getrealnumber(var number: stringnlen;
			var x: real);
  var
    bcd_str: bcd_strtype;
    mantissa_digit,i,expsign,
    nextchar,extraexponent: shortint;
    xvalid,decpnt,nonzero: boolean;
    ch: char;

  begin
    with bcd_str do
      begin
      xvalid := false;
      exponent := 0;       { 2's comp exponent }
      extraexponent := 0;  { amount of normalization }
      mantissa_digit := 1; { next digit to be inserted }
      signbit := pls;      { sign of real number }
      decpnt := false;     { have we seen a decimal point }
      nonzero := false;    { nonzero digit encountered }
      for i := 1 to 16 do mantissa[i] := 0;
      nextchar := 1;
      repeat
	ch := number[nextchar];
	nextchar := nextchar + 1;
      until (ch <> ' ');
      if (ch = '+') or (ch = '-') then
	begin
	if ch = '-' then signbit := mnus;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      while ch = '0' do
	begin
	xvalid := true;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      while (ch >= '0') and (ch <= '9') do
	begin
	nonzero := true;
	xvalid := true;
	if mantissa_digit <= 16 then
	  mantissa[mantissa_digit] := ord(ch) - ord('0');
	mantissa_digit := mantissa_digit + 1;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      if ch = '.' then
	begin
	extraexponent := mantissa_digit - 1;
	decpnt := true;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	while not nonzero and (ch = '0') do
	  begin
	  xvalid := true;
	  extraexponent := extraexponent - 1;
	  ch := number[nextchar];
	  nextchar := nextchar + 1;
	  end;
	while (ch >= '0') and (ch <= '9') do
	  begin
	  xvalid := true;
	  nonzero := true;
	  if mantissa_digit <= 16 then
	    mantissa[mantissa_digit] := ord(ch) - ord('0');
	  mantissa_digit := mantissa_digit + 1;
	  ch := number[nextchar];
	  nextchar := nextchar + 1;
	  end;
	end;
      if (ch in ['e','E','l','L']) and xvalid then
	begin
	ch := number[nextchar];
	nextchar := nextchar + 1;
	if ch in ['+','-','0'..'9'] then
	  begin
	  exponent := 0;
	  expsign := 1;
	  if (ch = '-') or (ch = '+')  then
	    begin
	    if ch = '-' then expsign := -1;
	    ch := number[nextchar];
	    nextchar := nextchar + 1;
	    end;
	  try
	    while (ch >= '0') and (ch <= '9') do
	      begin
	      exponent := exponent * 10 -
			  ord('0') + ord(ch);
	      ch := number[nextchar];
	      nextchar := nextchar + 1;
	      end;
	    exponent := exponent * expsign;
	  recover
	    if escapecode = -4 then  { intover }
	      xvalid := false
	    else escape(escapecode);
	  end
	else xvalid := false;
	end;
      if xvalid then
	if nonzero then
	  begin
	  if not decpnt then extraexponent := mantissa_digit - 1;
	  exponent := exponent + extraexponent;
	  try
	    asm_bcd_real(bcd_str,x);
	  recover
	    if escapecode = -20 then
	      escape(escapecode)
	    else
	      IORESULT := ord(IBADFORMAT);
	  end
	else x := 0.0
      else IORESULT := ord(IBADFORMAT);
      end;
  end; { getrealnumber }

procedure freadreal(var t: text; var x: real);
  var
    number: stringnlen;

  begin { freadreal }
  if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
  else begin                                                  { scs 1/17/83 }
       ioresult := ord(inoerror);
       if eof(t) then
	 ioresult := ord(ieof)
       else
	 inputreal(phile,t,'',number);
       if ioresult = ord(inoerror) then
	 getrealnumber(number,x);
       end;
  end; { freadreal }


procedure freadstrreal(var s: string255; var p2: integer; var x: real);
  var
    number: stringnlen;
    xxxxx: shortint;

  begin
  nextchr := 0;
  ioresult := ord(inoerror);
  if (p2<1) or (p2>strlen(s)) then
    ioresult := ord(istrovfl)
  else
    inputreal(strg,xxxxx,str(s,p2,strlen(s)-p2+1),number);
  if ioresult = ord(inoerror) then
    begin
    p2 := p2 + nextchr - 1;
    getrealnumber(number,x);
    end;
  end;

procedure asm_bcdround(bcd: bcd_strtype;
		       d: shortint;
		       var  s: string255);
		       external;
procedure asm_real_bcd(x: real; s: bcd_strtype);
  external;

procedure fwritestrreal (var r: string;
	var p2: integer; x: real; w,d: shortint);
  var
    bcd_str: bcd_strtype;
    s: string255;
    i,j,numdigits,minwidth: shortint;

  begin {fwritestrreal}
    ioresult := ord(inoerror);
    setstrlen(s,255);
    if x < 0 then
      begin
      minwidth := 9;
      x := -x;
      s[1] := '-';
      end
    else
      begin
      minwidth := 8;
      s[1] := ' ';
      end;
    if (d > 252) then d := -1;
    if w < 0 then w := 12;
    asm_real_bcd(x,bcd_str);
    with bcd_str do
      begin
      if x <> 0 then { mantissa between 1 and 10 }
	exponent := exponent - 1;
      if (d < 0) or (exponent >= 15) then
	begin
	if (w < minwidth) then w :=  minwidth;
	numdigits := w - (minwidth - 2)
	end
      else
	numdigits := d + exponent + 1;
      if numdigits < 0 then { number is 0.0 }
	begin
	s[1] := '0';
	s[2] := '.';
	if d > 0 then setstrlen(s,d+2)
		 else setstrlen(s,1);
	for j := 3 to strlen(s) do s[j] := '0';
	end
      else
	begin
	if numdigits > 15 then numdigits := 15;
	asm_bcdround(bcd_str,numdigits,s);
	if (d < 0) or (exponent >= 15) then
	  begin { scientific notation }
	  s[2] := s[3];
	  s[3] := '.';
	  j := numdigits + 3;
	  s[j] := 'E';
	  j := j + 1;
	  if exponent < 0 then
	    begin
	    s[j] := '-';
	    exponent := -exponent;
	    end
	  else s[j] := '+';
	  j := j + 1;
	  s[j] := chr(exponent DIV 100 + ord('0'));
	  j := j + 1;
	  s[j] := chr((exponent MOD 100) DIV 10
		  + ord('0'));
	  j := j + 1;
	  s[j] := chr(exponent MOD 10 + ord('0'));
	  setstrlen(s,j);
	  end
	else { fixed point notation }
	  if exponent >= 0 then
	    begin
	    for i := 2 to exponent + 2 do
	      s[i] := s[i+1];
	    s[3+exponent] := '.';
	    if d > 14 - exponent then
	      d := 14 - exponent;
	    if d = 0 then setstrlen(s,2+exponent)
		     else setstrlen(s,3+d+exponent);
	    end
	  else
	    begin
	    { numdigits may have changed }
	    numdigits := d + exponent + 1;
	    if numdigits > 14 then
	      numdigits := 14;
	    for i := numdigits+2 downto 3 do
	      s[i-exponent] := s[i];
	    s[2] := '0';
	    s[3] := '.';
	    fillchar(s[4],-exponent-1,'0');
	    if d > 14 then d := 14;
	    if d = 0 then setstrlen(s,2)
		     else setstrlen(s,3+d);
	    end;
	end;
      if s[1] = ' ' then {get rid of blank}
	begin
	moveleft(s[2],s[1],strlen(s)-1);
	setstrlen(s,strlen(s)-1);
	end;
      if w < strlen(s) then w := strlen(s);
      strwrite(r,p2,p2,s:w);
      end; { with bcd_str }
  end; { fwritestrreal }


procedure fwritereal
  (var t: text; x: real; w,d: shortint);
  var
    s: string255;
    dummy: integer;
  begin
  setstrlen(s,0);
  $range off$ strwrite(s,1,dummy,x:w:d);
  if ioresult = ord(inoerror) then
    fwritebytes(t,s[1],strlen(s));
  end;

end; { module mfs }

import mfs;

procedure asm_flpt_reset; external;


begin   { Code to initialize floating point hardware -- 10/26/83 jws }
  try
    flpt_present:=false;
    asm_flpt_reset;
    flpt_present:=true;
  recover
    if escapecode<>-12 { bus err}
      then escape(escapecode);
end. {more file support}

@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.3
log
@
pws2rcs automatic delta on Wed Aug 21 12:27:56 MDT 1991
@
text
@@


54.2
log
@
pws2rcs automatic delta on Wed Aug 21 09:35:48 MDT 1991
@
text
@d1 694
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@a0 694
$MODCAL,UCSD,sysprog,partial_eval,range off$
$iocheck off,ovflcheck off$

 program allrealstuff;
 module mfs;

	$copyright 'COPYRIGHT (C) 1982 BY HEWLETT-PACKARD COMPANY'$


import sysglobals,fs,sysdevs,misc,asm;

export

var

flpt_present['FLTPTHDW']: boolean;   {*** NOTE ABSOLUTE ADDRESS !!! }

procedure freadreal (var t: text; var x: real);
procedure fwritereal(var t: text; x: real; w,d: shortint);

procedure freadstrreal (var s: string255; var p2: integer; var x: real);
procedure fwritestrreal(var r: string;var p2: integer;x: real; w,d: shortint);

IMPLEMENT

  const
    nlen = 255;
  type
    stringnlen = string[nlen];
    sourcetype = (strg,phile);
    BCDdigit = 0..15; {0..9 are used}
    bcd_strtype = record
		    signbit: (pls,mnus);
		    mantissa: packed array[1..16] of BCDdigit;
		    exponent: shortint;
		  end;
  var
    nextchr: shortint;

procedure asm_bcd_real(s: bcd_strtype; x: real);
  external;


procedure inputreal(stype: sourcetype;
		    anyvar f: text;
		    fstrg: string255;
		    var number: stringnlen);

  label 1;
  const
    blank = ' ';
    backspace = chr(8);
    DEL = chr(127);
  var
    chr: char;
    firstchar,streof: boolean;
    nchars: shortint;

  procedure check_chr;
    var
      i: integer;
    begin
    if chr = DEL then
      if stype = phile then
	begin
	i := nchars;
	killchar(f,i);
	nchars := i;
	firstchar := true;
	escape(1);
	end
      else { stype = strg }
	nchars := 0
    else { chr = backspace }
      if stype = phile then
	begin
	i := nchars;
	killchar(f,i);
	nchars := i;
	firstchar := true;
	end
      else
	nchars := nchars - 1;
    end;

  procedure get1char;
    begin
    if nchars=nlen then escape(2);
      if stype = strg then
	begin
	nextchr := nextchr + 1;
	if nextchr > strlen(fstrg) then
	  if streof then escape(2)
	  else streof := true;
	if streof or (fstrg[nextchr]=eol) then
	  chr := blank
	else chr := fstrg[nextchr];
	end
      else {stype = phyle}
	begin
	if not firstchar then
	  get(f);
	firstchar := false;
	chr := f^;
	if ioresult <> ord(inoerror) then
	  escape(2);
	end;
    end; { get1char }

  procedure expodigit;
    { looking for <digit> }
    label 9;
    begin
    while true do
      begin
      get1char;
      if (chr >= '0') and (chr <= '9') then
	begin
	nchars := nchars + 1;
	number[nchars] := chr;
	end
      else
	begin
	if (chr = backspace) or (chr = DEL) then
	  begin
	  check_chr;
	  if ((number[nchars] < '0') or
	      (number[nchars] > '9')) then goto 9;
	  end
	else escape(3); {end of input}
	end;
      end;
  9:chr := number[nchars];
    end; { expodigit }

  procedure gotexposign;
    { looking for <digit> }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expodigit;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    goto 9;
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end; { gotexposign }

  procedure expostate;
    { looking for <digit>, '+', '-' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expodigit;
	  end
	else if (chr = '+') or (chr = '-') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  gotexposign;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    goto 9;
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end;

  procedure fracstate;
    { looking for <digit>, 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr = 'E') or (chr = 'e') or
	   (chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    if (number[nchars+1] = '.') then
	      goto 9;
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { fracstate }

  procedure mantissadigitA;
    { looking for <digit>, '.', 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then {ok}
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else if (chr = 'E') or (chr = 'e') or
		(chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { mantissadigitA }

  procedure mantissadigitB;
    { looking for <digit>, '.', 'E', 'e', 'L', 'l' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then {ok}
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  end
	else if (chr = '.') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else if (chr = 'E') or (chr = 'e') or
		(chr = 'L') or (chr = 'l') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  expostate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if ((number[nchars] = '+') or
		(number[nchars] = '-')) then goto 9;
	    end
	  else escape(3); { end of input }
	  end;
	end;
  9:  chr := number[nchars];
    end; { mantissadigitB }

  procedure gotmantissasign;
    { looking for <digit>, '.' }
    label 9;
    begin
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  mantissadigitB;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    if nchars = 0 then escape(1);
	    end
	  else escape(2); { error }
	  end;
	end;
  9:  chr := number[nchars];
    end;

  procedure startstate;
    { looking for '+', '-', '.', <digit> }
    begin
      nchars := 0;
      setstrlen(number,strmax(number));
      while true do
	begin
	get1char;
	if (chr >= '0') and (chr <= '9') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  mantissadigitA;
	  end
	else if (chr = '+') or (chr = '-') then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  gotmantissasign;
	  end
	else if chr = '.' then
	  begin
	  nchars := nchars + 1;
	  number[nchars] := chr;
	  fracstate;
	  end
	else
	  begin
	  if (chr = backspace) or (chr = DEL) then
	    begin
	    check_chr;
	    escape(1);
	    end
	  else if (chr <> blank) then
	    escape(2); { error }
	  end;
	end;
    end; { startstate }

  begin { inputreal }
    streof := false;
    firstchar := true;
1:  try
      startstate;
    recover
      if escapecode = 1 then goto 1
      else if escapecode = 2 then    { error }
	begin
	if ioresult = ord(inoerror) then
	  IORESULT := ord(IBADFORMAT);
	end
      else if escapecode = 3 then
	begin
	nchars := nchars + 1;
	number[nchars] := blank;
	end
      else escape(escapecode);
  end; { inputreal }

procedure getrealnumber(var number: stringnlen;
			var x: real);
  var
    bcd_str: bcd_strtype;
    mantissa_digit,i,expsign,
    nextchar,extraexponent: shortint;
    xvalid,decpnt,nonzero: boolean;
    ch: char;

  begin
    with bcd_str do
      begin
      xvalid := false;
      exponent := 0;       { 2's comp exponent }
      extraexponent := 0;  { amount of normalization }
      mantissa_digit := 1; { next digit to be inserted }
      signbit := pls;      { sign of real number }
      decpnt := false;     { have we seen a decimal point }
      nonzero := false;    { nonzero digit encountered }
      for i := 1 to 16 do mantissa[i] := 0;
      nextchar := 1;
      repeat
	ch := number[nextchar];
	nextchar := nextchar + 1;
      until (ch <> ' ');
      if (ch = '+') or (ch = '-') then
	begin
	if ch = '-' then signbit := mnus;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      while ch = '0' do
	begin
	xvalid := true;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      while (ch >= '0') and (ch <= '9') do
	begin
	nonzero := true;
	xvalid := true;
	if mantissa_digit <= 16 then
	  mantissa[mantissa_digit] := ord(ch) - ord('0');
	mantissa_digit := mantissa_digit + 1;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	end;
      if ch = '.' then
	begin
	extraexponent := mantissa_digit - 1;
	decpnt := true;
	ch := number[nextchar];
	nextchar := nextchar + 1;
	while not nonzero and (ch = '0') do
	  begin
	  xvalid := true;
	  extraexponent := extraexponent - 1;
	  ch := number[nextchar];
	  nextchar := nextchar + 1;
	  end;
	while (ch >= '0') and (ch <= '9') do
	  begin
	  xvalid := true;
	  nonzero := true;
	  if mantissa_digit <= 16 then
	    mantissa[mantissa_digit] := ord(ch) - ord('0');
	  mantissa_digit := mantissa_digit + 1;
	  ch := number[nextchar];
	  nextchar := nextchar + 1;
	  end;
	end;
      if (ch in ['e','E','l','L']) and xvalid then
	begin
	ch := number[nextchar];
	nextchar := nextchar + 1;
	if ch in ['+','-','0'..'9'] then
	  begin
	  exponent := 0;
	  expsign := 1;
	  if (ch = '-') or (ch = '+')  then
	    begin
	    if ch = '-' then expsign := -1;
	    ch := number[nextchar];
	    nextchar := nextchar + 1;
	    end;
	  try
	    while (ch >= '0') and (ch <= '9') do
	      begin
	      exponent := exponent * 10 -
			  ord('0') + ord(ch);
	      ch := number[nextchar];
	      nextchar := nextchar + 1;
	      end;
	    exponent := exponent * expsign;
	  recover
	    if escapecode = -4 then  { intover }
	      xvalid := false
	    else escape(escapecode);
	  end
	else xvalid := false;
	end;
      if xvalid then
	if nonzero then
	  begin
	  if not decpnt then extraexponent := mantissa_digit - 1;
	  exponent := exponent + extraexponent;
	  try
	    asm_bcd_real(bcd_str,x);
	  recover
	    if escapecode = -20 then
	      escape(escapecode)
	    else
	      IORESULT := ord(IBADFORMAT);
	  end
	else x := 0.0
      else IORESULT := ord(IBADFORMAT);
      end;
  end; { getrealnumber }

procedure freadreal(var t: text; var x: real);
  var
    number: stringnlen;

  begin { freadreal }
  if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable)
  else begin                                                  { scs 1/17/83 }
       ioresult := ord(inoerror);
       if eof(t) then
	 ioresult := ord(ieof)
       else
	 inputreal(phile,t,'',number);
       if ioresult = ord(inoerror) then
	 getrealnumber(number,x);
       end;
  end; { freadreal }


procedure freadstrreal(var s: string255; var p2: integer; var x: real);
  var
    number: stringnlen;
    xxxxx: shortint;

  begin
  nextchr := 0;
  ioresult := ord(inoerror);
  if (p2<1) or (p2>strlen(s)) then
    ioresult := ord(istrovfl)
  else
    inputreal(strg,xxxxx,str(s,p2,strlen(s)-p2+1),number);
  if ioresult = ord(inoerror) then
    begin
    p2 := p2 + nextchr - 1;
    getrealnumber(number,x);
    end;
  end;

procedure asm_bcdround(bcd: bcd_strtype;
		       d: shortint;
		       var  s: string255);
		       external;
procedure asm_real_bcd(x: real; s: bcd_strtype);
  external;

procedure fwritestrreal (var r: string;
	var p2: integer; x: real; w,d: shortint);
  var
    bcd_str: bcd_strtype;
    s: string255;
    i,j,numdigits,minwidth: shortint;

  begin {fwritestrreal}
    ioresult := ord(inoerror);
    setstrlen(s,255);
    if x < 0 then
      begin
      minwidth := 9;
      x := -x;
      s[1] := '-';
      end
    else
      begin
      minwidth := 8;
      s[1] := ' ';
      end;
    if (d > 252) then d := -1;
    if w < 0 then w := 12;
    asm_real_bcd(x,bcd_str);
    with bcd_str do
      begin
      if x <> 0 then { mantissa between 1 and 10 }
	exponent := exponent - 1;
      if (d < 0) or (exponent >= 15) then
	begin
	if (w < minwidth) then w :=  minwidth;
	numdigits := w - (minwidth - 2)
	end
      else
	numdigits := d + exponent + 1;
      if numdigits < 0 then { number is 0.0 }
	begin
	s[1] := '0';
	s[2] := '.';
	if d > 0 then setstrlen(s,d+2)
		 else setstrlen(s,1);
	for j := 3 to strlen(s) do s[j] := '0';
	end
      else
	begin
	if numdigits > 15 then numdigits := 15;
	asm_bcdround(bcd_str,numdigits,s);
	if (d < 0) or (exponent >= 15) then
	  begin { scientific notation }
	  s[2] := s[3];
	  s[3] := '.';
	  j := numdigits + 3;
	  s[j] := 'E';
	  j := j + 1;
	  if exponent < 0 then
	    begin
	    s[j] := '-';
	    exponent := -exponent;
	    end
	  else s[j] := '+';
	  j := j + 1;
	  s[j] := chr(exponent DIV 100 + ord('0'));
	  j := j + 1;
	  s[j] := chr((exponent MOD 100) DIV 10
		  + ord('0'));
	  j := j + 1;
	  s[j] := chr(exponent MOD 10 + ord('0'));
	  setstrlen(s,j);
	  end
	else { fixed point notation }
	  if exponent >= 0 then
	    begin
	    for i := 2 to exponent + 2 do
	      s[i] := s[i+1];
	    s[3+exponent] := '.';
	    if d > 14 - exponent then
	      d := 14 - exponent;
	    if d = 0 then setstrlen(s,2+exponent)
		     else setstrlen(s,3+d+exponent);
	    end
	  else
	    begin
	    { numdigits may have changed }
	    numdigits := d + exponent + 1;
	    if numdigits > 14 then
	      numdigits := 14;
	    for i := numdigits+2 downto 3 do
	      s[i-exponent] := s[i];
	    s[2] := '0';
	    s[3] := '.';
	    fillchar(s[4],-exponent-1,'0');
	    if d > 14 then d := 14;
	    if d = 0 then setstrlen(s,2)
		     else setstrlen(s,3+d);
	    end;
	end;
      if s[1] = ' ' then {get rid of blank}
	begin
	moveleft(s[2],s[1],strlen(s)-1);
	setstrlen(s,strlen(s)-1);
	end;
      if w < strlen(s) then w := strlen(s);
      strwrite(r,p2,p2,s:w);
      end; { with bcd_str }
  end; { fwritestrreal }


procedure fwritereal
  (var t: text; x: real; w,d: shortint);
  var
    s: string255;
    dummy: integer;
  begin
  setstrlen(s,0);
  $range off$ strwrite(s,1,dummy,x:w:d);
  if ioresult = ord(inoerror) then
    fwritebytes(t,s[1],strlen(s));
  end;

end; { module mfs }

import mfs;

procedure asm_flpt_reset; external;


begin   { Code to initialize floating point hardware -- 10/26/83 jws }
  try
    flpt_present:=false;
    asm_flpt_reset;
    flpt_present:=true;
  recover
    if escapecode<>-12 { bus err}
      then escape(escapecode);
end. {more file support}

@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
