File : reps-io.adb

pragma Optimize (Off);

package body Reps.IO is

  use Rep_IO;

  function Val(S: String) return Rep is
    function V(C: Character) return Integer is
    begin
      for K in 1 .. 15 loop
        if C=HexDig(K) then return K; end if;
      end loop;
      return 0;
    end V;
    E1,E2,Ed1,Es2,Ms: Integer := 0;
    R: Rep := Zero;
  begin
    for K in S'Range loop
      if S(K)=' ' then
        null;
      elsif S(K)='+' then
        if Ms=0 then Ms := 1; else Es2 := 1; end if;
      elsif S(K)='-' then
        if Ms=0 then Ms := -1; else Es2 := -1; end if;
      elsif Es2=0 then
        if Ms=0 then Ms := 1; end if;
        if S(K)='.' then
          Ed1 := -1;
        else
          R := Rep(16)*R+Rep(V(S(K)));
          E1 := E1+Ed1;
        end if;
      else
        E2 := 16*E2+V(S(K));
      end if;
    end loop;
    R := Rep(Ms)*Rep'Scaling(R,4*(E1+Es2*E2));
    return R;
  end Val;

  function HexStr(I: Integer) return String is
    Nhex: constant Integer := 1+Integer'Size/4;
    S: String(1 .. Nhex);
    J: Integer := Abs(I);
  begin
    for N in reverse 1 .. Nhex loop
      S(N) := HexDig(J mod 16);
      J := J/16;
      if J=0 then
        if I<0 then return "-" & S(N .. Nhex);
        else return "+" & S(N .. Nhex); end if;
      end if;
    end loop;
    raise Constraint_Error;
    return "+0";
  end HexStr;

  function RepCompose(R: in Rep; E: in Integer) return Rep is
--- workaround for a bug in Aonix ObjectAda 8.2
  begin
    return Rep'Compose(Rep'Fraction(R),E);
  end RepCompose;

  function HexStr(R: Rep) return String is
  begin
    if R=0.0 then return " 0.0+0"; end if;
    declare
      Nhex: constant Integer := 1+Rep'Machine_Mantissa/4;
      E:    constant Integer := Rep'Exponent(R)-1;
      F:    constant Integer := E mod 4;
      M:    constant Rep     := RepCompose(Abs(R),F+1);
      L: Rep;
      S: String(1 .. Nhex+2);
    begin
      if R<0.0 then S(1) := '-'; else S(1) := '+'; end if;
      L := Rep'Leading_Part(M,F+1);
      S(2) := HexDig(Integer(Rep'Floor(L)));
      S(3) := '.';
      for N in 1 .. Nhex-1 loop
        L := M-Rep'Leading_Part(M,F-3+4*N);
        S(N+3) := HexDig(Integer(Rep'Floor(L*Rep(16)**N)));
      end loop;
      return S & HexStr((E-F)/4);
    end;
  end HexStr;

  procedure Show0(N: in String) is
  begin
    Put(N);
    New_Line;
  end Show0;

  procedure Show1(N: in String; R: in Rep) is
  begin
    Put(N);
    Put(R,3,17,4);
    New_Line;
  end Show1;

  procedure Show2(N: in String; R1,R2: in Rep) is
  begin
    Put(N);
    Put(R1,3,17,4);
    Put(R2,3,17,4);
    New_Line;
  end Show2;

  procedure Show3(N: in String; R1,R2,R3: in Rep; NewLine: in Boolean := True) is
  begin
    Put(N);
    Put(R1,3,17,4);
    if R3 /= Zero then
      Put(R2,3,5,3);
      Put(R3,3,5,3);
    elsif R2 /= Zero then
      Put(R2,3,5,3);
    end if;
    if NewLine then New_Line; end if;
  end Show3;

  procedure Get(F: in File_Type; R: out Rep; Decimal: in Boolean := True) is
    I: Integer := 0;
    S: String(1..32);
  begin
    if Decimal then Rep_IO.Get(F,R); return; end if;
    while I=0 loop
      Get_Line(File=>F, Item=>S, Last=>I);
    end loop;
    R := Val(S(1..I));
  end Get;

  procedure Get(F: in File_Type; R1,R2: out Rep; Decimal: in Boolean := True) is
    I: Integer := 0;
    S: String(1..64);
  begin
    R2 := Zero;
    if Decimal then Rep_IO.Get(F,R1); return; end if;
    while I=0 loop
      Get_Line(File=>F, Item=>S, Last=>I);
    end loop;
    for N in 2 .. I-1 loop
      if S(N)=',' then
        R1 := Val(S(1 .. N-1));
        R2 := Val(S(N+1 .. I));
        return;
      end if;
    end loop;
    R1 := Val(S(1..I));
  end Get;

  procedure Get(F: in File_Type; R1,R2,R3: out Rep; Decimal: in Boolean := True) is
    I: Integer := 0;
    S: String(1..96);
  begin
    R2 := Zero;
    R3 := Zero;
    if Decimal then Rep_IO.Get(F,R1); return; end if;
    while I=0 loop
      Get_Line(File=>F, Item=>S, Last=>I);
    end loop;
    for N in 2 .. I-1 loop
      if S(N)=',' then
        R1 := Val(S(1 .. N-1));
        for M in N+1 .. I-1 loop
          if S(M)=',' then
            R2 := Val(S(N+1 .. M-1));
            R3 := Val(S(M+1 .. I));
            return;
          end if;
        end loop;
        R2 := Val(S(N+1 .. I));
        return;
      end if;
    end loop;
    R1 := Val(S(1..I));
  end Get;

  procedure Put(F: in File_Type; R: in Rep; Decimal: in Boolean := True) is
--- Long_Float approx 16 decimal digits
--- Long_Long_Float only 17 decimal digits
  begin
    if Decimal then
      Put(F,R,2,17,4);  --- approximate
    else
      Put(F,HexStr(R));
    end if;
    New_Line(F);
  end Put;

  procedure Put(F: in File_Type; R1,R2: in Rep; Decimal: in Boolean := True) is
  begin
    if (R2=Zero) or else Decimal then
      Put(F,R1,Decimal);  --- approximate
    else
      Put(F,HexStr(R1) & "," & HexStr(R2));
      New_Line(F);
    end if;
  end Put;

  procedure Put(F: in File_Type; R1,R2,R3: in Rep; Decimal: in Boolean := True) is
  begin
    if (R3=Zero) or else Decimal then
      Put(F,R1,R2,Decimal);  --- approximate
    else
      Put(F,HexStr(R1) & "," & HexStr(R2) & "," & HexStr(R3));
      New_Line(F);
    end if;
  end Put;

end Reps.IO;