-- IeeeIOB.mesa
-- Last Modified: August 27, 1982 1:05 pm
-- String munging for IO

DIRECTORY
  Ascii USING [CR, DEL, TAB],
  Ieee USING [BitOn, HalfLC, HiBit],
  Inline USING [HighHalf, LowHalf],
  String USING [AppendChar, AppendString],
  Real USING [DefaultSinglePrecision, NumberType, PairToReal, RealToPair];

IeeeIOB: CEDAR PROGRAM IMPORTS Ieee, Inline, String, Real EXPORTS Real =
  BEGIN OPEN Ascii, Ieee, Real, String;

  DefaultPutback: PUBLIC PROC [c: CHARACTER] = {NULL; };

  ReadReal: PUBLIC PROC [get: PROC RETURNS [CHARACTER], putback: PROC [CHARACTER]]
    RETURNS [REAL] = {
    InsideProc: PROC RETURNS [REAL] = {
      exp, exp2, cVal, digits: INTEGER ← 0;
      val: REAL;
      intVal: LONG INTEGER ← 0;
      minus, expMinus: BOOLEAN ← FALSE;
      leadZeros: BOOLEAN ← TRUE;
      mode: {firstSymbol, intPart, fracPart, firstExpSymbol, expPart} ←
	firstSymbol;
      c: CHARACTER;
      Ten: INTEGER = 10;
      DigitLimit: INTEGER = 9; -- digits is a way to prevent overflow of intVal
      DO
	c ← get[];
	cVal ← LOOPHOLE[c - '0, INTEGER];
	SELECT c FROM
	  ' , CR, TAB, DEL => SELECT mode FROM firstSymbol => NULL; ENDCASE => EXIT;
	  '+ =>
	    SELECT mode FROM
	      firstSymbol => mode ← intPart;
	      firstExpSymbol => mode ← expPart;
	      ENDCASE => EXIT;
	  '- =>
	    SELECT mode FROM
	      firstSymbol => {minus ← TRUE; mode ← intPart; };
	      firstExpSymbol => {expMinus ← TRUE; mode ← expPart; };
	      ENDCASE => EXIT;
	  '. =>
	    SELECT mode FROM
	      firstSymbol, intPart => mode ← fracPart;
	      ENDCASE => EXIT;
	  'D, 'E, 'd, 'e =>
	    SELECT mode FROM
	      intPart, fracPart => mode ← firstExpSymbol;
	      ENDCASE => EXIT;
	  IN ['0..'9] =>
	    SELECT mode FROM
	      firstSymbol, intPart =>
		IF digits < DigitLimit THEN {
		  IF cVal # 0 THEN leadZeros ← FALSE;
		  mode ← intPart;
		  intVal ← intVal*Ten + cVal;
		  IF NOT leadZeros THEN digits ← digits + 1;
		  }
		ELSE exp ← exp + 1;
	      fracPart =>
		IF digits < DigitLimit THEN {
		  IF cVal # 0 THEN leadZeros ← FALSE;
		  intVal ← intVal*Ten + cVal;
		  exp ← exp - 1;
		  IF NOT leadZeros THEN digits ← digits + 1;
		  };
	      firstExpSymbol, expPart => {
		mode ← expPart; exp2 ← exp2*10 + cVal; };
	      ENDCASE => EXIT;
	  ENDCASE => EXIT;
	ENDLOOP;
      putback[c]; -- now put it together
      IF expMinus THEN exp2 ← -exp2;
      exp ← exp + exp2;
      val ← PairToReal[intVal, exp];
      IF minus THEN
	LOOPHOLE[val, LONG CARDINAL] ← LOOPHOLE[val, LONG CARDINAL] + HalfLC;
      RETURN[val];
      };
    RETURN[InsideProc[]];
    };

  AppendReal: PROC [
    s: STRING, r: REAL, precision: CARDINAL ← DefaultSinglePrecision,
    forceE: BOOLEAN ← FALSE] = TRUSTED {
    exp: INTEGER;
    z: LONG INTEGER;
    ty: NumberType;
    sign: BOOLEAN;
    Zeros: PROC [n: CARDINAL] = TRUSTED {THROUGH [1..n] DO AppendChar[s, '0]; ENDLOOP; };
    {
    sign ← BitOn[Inline.HighHalf[r], HiBit];
    [type: ty, fr: z, exp10: exp] ← RealToPair[r, precision];
    IF sign THEN z ← -z;
    SELECT ty FROM
      nan => AppendString[to: s, from: ".."];
      infinity => AppendString[to: s, from: IF sign THEN "--" ELSE "++"];
      zero => AppendString[to: s, from: IF sign THEN "-0" ELSE "0"];
      ENDCASE => GOTO Ok;
    EXITS
      Ok => {
	lds: STRING ← [20];
	rds: STRING ← [20];
	i, digit, digits, ld, rd: CARDINAL;
	IF sign THEN AppendChar[s, '-];
	IF z = 0 THEN {AppendChar[s, '0]; RETURN; }; -- leading zeros
	digits ← precision ← MAX[1, MIN[precision, 9]];
	WHILE (z MOD 10) = 0 DO
	  -- strip trailing zeros
	  z ← z/10;
	  exp ← exp + 1;
	  digits ← digits - 1;
	  ENDLOOP;
	IF digits = 0 THEN ERROR;
	rd ← MAX[0, -exp];
	rds.length ← MIN[digits, rd]; -- right digit string
	FOR i DECREASING IN [0..rds.length) DO
	  digit ← Inline.LowHalf[z MOD 10];
	  z ← z/10;
	  rds[i] ← digit + '0;
	  ENDLOOP;
	ld ← MAX[0, LOOPHOLE[digits, INTEGER] + exp];
	lds.length ← MIN[digits, ld]; -- left digit string
	FOR i DECREASING IN [0..lds.length) DO
	  digit ← Inline.LowHalf[z MOD 10];
	  z ← z/10;
	  lds[i] ← digit + '0;
	  ENDLOOP;
	forceE ← forceE OR ld > 6 OR rd > 6;
	IF NOT forceE THEN
	  SELECT TRUE FROM
	    ld = 0 => {
	      -- number entirely to right of decimal point
	      AppendString[to: s, from: "0."];
	      Zeros[rd - rds.length];
	      AppendString[to: s, from: rds];
	      };
	    rd = 0 => {
	      -- number entirely to left of decimal point
	      AppendString[to: s, from: lds];
	      Zeros[ld - lds.length];
	      };
	    ENDCASE => {
	      -- some of each
	      AppendString[to: s, from: lds];
	      AppendChar[s, '.];
	      AppendString[to: s, from: rds];
	      }
	ELSE {
	  -- e format
	  AppendString[to: lds, from: rds];
	  AppendChar[s, lds[0]];
	  lds.length ← lds.length;
	  exp ← exp + lds.length - 1;
	  SELECT TRUE FROM
	    precision = 1 => AppendChar[s, '.];
	    lds.length = 1 => AppendString[to: s, from: ".0"];
	    ENDCASE => {
	      AppendChar[s, '.];
	      FOR i IN [1..lds.length) DO AppendChar[s, lds[i]]; ENDLOOP;
	      }; -- print exponent
	  IF exp = 0 THEN RETURN;
	  AppendChar[s, 'e];
	  AppendChar[s, IF exp < 0 THEN '- ELSE '+];
	  exp ← ABS[exp];
	  IF exp > 9 THEN AppendChar[s, '0 + (exp/10)];
	  AppendChar[s, '0 + (exp MOD 10)];
	  };
	};
    };
    };

  WriteReal: PUBLIC PROC [
    cp: PROC [CHARACTER], r: REAL, precision: CARDINAL ← DefaultSinglePrecision,
    forceE: BOOLEAN ← FALSE] = TRUSTED {
    s: STRING ← [50];
    i: CARDINAL;
    AppendReal[s, r, precision, forceE];
    FOR i IN [0..s.length) DO cp[s[i]]; ENDLOOP;
    };

  END.
L. Stewart, July 12, 1980  10:37 PM, Name changes
L. Stewart, July 13, 1980  8:57 PM, delete WF procwedures (Moved to WFReal)
August 24, 1980  8:42 PM, L. Stewart; formatting, fix ReadReal
December 11, 1980  11:06 AM, L. Stewart; Use Ascii instead of IODefs
June 5, 1982 5:58 pm, L. Stewart, removed STRING conversions
August 27, 1982 1:05 pm, L. Stewart, CEDAR