-- NAN_PAYLOAD provides access to the payload bits from Long_Float IEEE754 NaN values
-- Copyright (c) 2014 Alexandru Dan Corlan M.D. PhD
--
-- Home page: http://dan.corlan.net/software/nan_payload
--
-- nan_payload is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the
-- Free Software Foundation; either version 3, or (at your option)
-- any later version. CORLPACK is distributed in the hope that it
-- will be useful, but WITHOUT ANY WARRANTY; without even the
-- implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-- PURPOSE. As a special exception under Section 7 of GPL version 3,
-- you are granted additional permissions described in the GCC
-- Runtime Library Exception, version 3.1, as published by the Free
-- Software Foundation, only for the packages (not for the tests
-- and utilities) included in this distribution.
--
-- You should have received a copy of the GNU General Public License
-- and a copy of the GCC Runtime Library Exception along with this
-- program; see the files COPYING3 and COPYING.RUNTIME respectively.
-- If not, see .
--
-- Storing 'non-available', error as well as other symbolic values instead of any of the
-- numbers in numeric arrays is necessary in many statistical applications.
--
-- This package allows you to read and write the part of NaN IEEE754-64 bit values
-- known as `the payload' that is 51 bits long, and also to treat the long_float
-- type as an implicit tagged type by storing tags and values in the payload.
-- Calendar dates with ms resolution as well as 9-letter symbols and some
-- not available/error codes are provided as subtypes. Formatted output with
-- Fortran-like descriptors as well as reading values from strings
-- for these types is also provided.
--
-- History: this is version 0.1, released june 5, 2014
-- tested only with gnat 4.6 on linux, x86_64, and the Atom-D2550 processor
with Ada.Calendar; use Ada.Calendar;
with Gnat.Calendar.Time_Io; use Gnat.Calendar.Time_Io;
package Nan_Payload_64 is
pragma Elaborate_Body(Nan_Payload_64);
-- first level package: simply provide access to the 51 bits (the 'payload')
-- of IEEE754 64 bit floats
subtype Num is Long_Float;
type Payload is mod 2**51;
type Uint64 is mod 2**64;
-- predicates for NaN, infinity and normal long_float values
function Is_Nan(X: Num) return Boolean;
function Is_Num(X: Num) return Boolean; -- neither nan, nor +/- inf, otherwise valid
function Is_Plus_Inf(X: Num) return Boolean;
function Is_Minus_Inf(X: Num) return Boolean;
function Is_Inf(X: Num) return Boolean; -- either plus or minus infinity
function Nanval(X: Num) return Payload; -- raises constranit_error if X is not a NaN
function To_Nan(J: Payload) return Num;
function Eq(X,Y: Num) return Boolean;
-- = does not properly work; use Eq to test for identical NaN values
-- EXAMPLE SCHEMA
-- frequently used values
-- this are supposed to also fit into the 22 bits of 32-bit floats,
-- that will be developed some other time
Nan_Zero: Num; -- this is the NaN with a 0 payload, as produced by 0.0/0.0
Nan_True: Num; -- some randomly choosen values (starting with mostly 1's)
Nan_False: Num;
Nan_Ok: Num;
Nan_Na: Num;
Nan_Err: Num;
Nan_Err_1: Num;
Nan_Err_2: Num;
-- for the rest of the types, each payload is divided into a 'cls' (class or tag)
-- and a value; some later types have a cls of 3 bits and a value of 48 bits,
-- but types that will have to also be coercible to 22 bits will have a cls of at least
-- 29 bits, starting with 29 '1's and a value of 22 or less, like the above (see
-- the initialisation code in the package body)
function Make(Cls: Uint64; Mask: Integer; Value: Uint64) return Num; -- num is a NaN
function Peek(N: Num; Mask: Integer) return Uint64;
-- if mask is negative then return the type (that number of bits at the start)
-- if mask is positive then return the value (that number of bits at the end)
-- symbols: up to 9 case-less letters, 0-9, ".", "_", ":" or "@" except
-- that the last character cannot be a "@"
function Is_Sym_Nan(X: Num) return Boolean;
function To_Sym_Nan(S: String) return Num;
function To_Str(X: Num) return String;
-- calendar time: milliseconds since the start of the Gregorian calendar
function Is_Time_Nan(X: Num) return Boolean;
function To_time(X: Num) return Time;
function To_Time_Nan(X: Time) return Num;
-- 'input' and 'output' functions: convert NaNs into
-- readable ascii strings (Img) and back (Val)
-- only formats "s" and "" supported for NaNs
-- "s" displays symbols and time when known;
-- "" and unknown values to "s" result in a generic format
-- that is nan:.. is the three bit class while
-- the 12 hex digits represent the 48bit value
-- If the value is not a NaN then F10.3 writes it in 10 space-padded
-- characters with 3 decimals
function Img(X: Num; Format: String:= "s") return String;
function Val(S: String) return Num;
-- the following are visible just for testing
Wrong_Nan_Type: exception;
Wrong_Format: exception;
Sym_Type_Id: constant Uint64:= 5;
Time_Type_Id: constant Uint64:= 4;
function B40_To_String(B: Payload) return String;
function String_To_B40(S: String) return Payload;
end Nan_Payload_64;
with Ada.Unchecked_Conversion;
with Ada.Text_Io;
package body Nan_Payload_64 is
Nan0: Uint64:= 16#fff8_0000_0000_0000#;
Zero: Num:= 0.0;
function Lf_To_Li is new Ada.Unchecked_Conversion(Source => Num, Target => Uint64);
function Li_To_Lf is new Ada.Unchecked_Conversion(Source => Uint64, Target => Num);
Minus_Inf: Uint64:= Lf_To_Li(-1.0/Zero);
Plus_Inf: Uint64:= Lf_To_Li(1.0/Zero);
function Eq(X,Y: Num) return Boolean is
begin
return Lf_To_Li(X)=Lf_To_Li(Y);
end Eq;
function Is_Nan(X: Num) return Boolean is
L: Uint64:= Lf_To_Li(X);
begin
return (L and Nan0) = Nan0;
end Is_Nan;
function Is_Plus_Inf(X: Num) return Boolean is
begin
return Lf_To_Li(X) = Plus_Inf;
end Is_Plus_Inf;
function Is_Minus_Inf(X: Num) return Boolean is
begin
return Lf_To_Li(X) = Minus_Inf;
end Is_Minus_Inf;
function Is_Inf(X: Num) return Boolean is
begin
return Is_Plus_Inf(X) or else Is_Minus_Inf(X);
end Is_Inf;
function Is_Num(X: Num) return Boolean is
begin
return not Is_Nan(X) and then not Is_Inf(X);
end Is_Num;
function Nanval(X: Num) return Payload is
L: Uint64:= Lf_To_Li(X);
begin
if (L and Nan0) = Nan0 then
return Payload(L and not Nan0);
else
raise Constraint_Error; -- not a nan number
end if;
end Nanval;
function To_Nan(J: Payload) return Num is
begin
return Li_To_Lf(Nan0 or (Uint64(J) and not Nan0));
end To_Nan;
function Make(Cls: Uint64; Mask: Integer; Value: Uint64) return Num is
begin
return To_Nan(Payload(((Cls and Uint64(2**Mask - 1)) * 2**(51-Mask)) + Value));
end Make;
function Peek(N: Num; Mask: Integer) return Uint64 is
begin
if Mask>0 then
return Uint64(Lf_To_Li(N)) and Uint64(2**(51-Mask)-1);
else
return Uint64(Lf_To_Li(N))/2**(51+Mask) and Uint64(2**(-Mask)-1);
end if;
end Peek;
subtype Base40char is Short_Short_Integer range -1..39;
Badchar: Short_Short_Integer:= -1;
Char_To_Base40: array(Character) of Base40char := (others => Badchar);
Base40_To_Char: constant array(Base40char) of Character :=
( ' ', '0', '1', '2', '3', '4', '5',
'6', '7', '8', '9', 'A', 'B',
'C', 'D', 'E', 'F',
'G', 'H', 'I', 'J', 'K', 'L',
'M', 'N', 'O', 'P', 'Q', 'R',
'S', 'T', 'U', 'V', 'W', 'X',
'Y', 'Z', '.', '_', ':', '@');
procedure Init_B40 is
begin
for K in Character'('0')..Character'('9') loop
Char_To_Base40(K) := Base40char(Character'Pos(K) - Character'Pos('0'));
end loop;
for K in Character'('A')..Character'('Z') loop
Char_To_Base40(K) := Base40char(Character'Pos(K) - Character'Pos('A') + 10);
end loop;
for K in Character'('a')..Character'('z') loop
Char_To_Base40(K) := Base40char(Character'Pos(K) - Character'Pos('a') + 10);
end loop;
Char_To_Base40('.') := 36;
Char_To_Base40('_') := 37;
Char_To_Base40(':') := 38;
Char_To_Base40('@') := 39;
end Init_B40;
Impossible_Exception: exception;
function String_To_B40(S: String) return Payload is
R: Payload:= 0;
U: String:= S & "@@@@@@@@@";
K: Integer:= U'First;
Nc: Integer:= 0;
B: Base40char;
begin
while K=1 loop
Re := Re-1;
end loop;
return R(1..Re);
end B40_To_String;
function Is_Sym_Nan(X: Num) return Boolean is
begin
return Peek(X,-3)=Sym_Type_Id;
end Is_Sym_Nan;
function To_Sym_Nan(S: String) return Num is
begin
return Make(Sym_Type_Id,3,Uint64(String_To_B40(S)));
end To_Sym_Nan;
function To_Str(X: Num) return String is
begin
if Is_Sym_Nan(X) then
return B40_To_String(Payload(Peek(X,3)));
else
raise Wrong_Nan_Type;
end if;
end To_Str;
function Is_Time_Nan(X: Num) return Boolean is
begin
return Peek(X,-3)=4;
end Is_Time_Nan;
Gregorian_Epoch: constant Time:= Time_Of(1982,10,15);
Days_In_400_Years: constant Uint64:= 146097;
-- gregorian years of 365.2425 days each; fits exactly after 400 years
Seconds_In_400_Years: constant Uint64:= Days_In_400_Years * 24 * 3600;
function To_time(X: Num) return Time is
begin
return Gregorian_Epoch + Duration((Long_Float(Peek(X,3)) - Long_Float(Seconds_In_400_Years*1000))/1000.0);
end To_time;
function To_Time_Nan(X: Time) return Num is
begin
return Make(Time_Type_Id,3,Uint64((Long_Float(X - Time_Of(1982,10,15)) +
Long_Float(Seconds_In_400_Years))*1000.0));
end To_Time_Nan;
-- that is, format
Pltime_Format: Picture_String:= "%Y-%m-%d/%H;%M:%S.%i";
function Read_Pltime(S: String) return Time is
U: String(1..S'Length):= S;
R: Time;
Ms: Duration;
begin
U(11) := ' ';
R := Value(U(1..19));
Ms := Duration'Value(U(21..23))/1000.0;
return R+Ms;
end Read_Pltime;
function Img(X: Num; Format: String:= "s") return String is
package Numio is new Ada.Text_Io.Float_Io(Num);
function Gen_Nan_Form(X: Num) return String is
Genan: String(1..17):= "nan0:000000000000";
function Hexdig(N: Integer) return Character is
begin
if N>0 and then N<10 then
return Character'Val(Character'Pos('0') + N);
elsif N<16 then
return Character'Val(Character'Pos('a') + N - 10);
else
raise Constraint_Error;
end if;
end Hexdig;
Y: Uint64;
begin
Genan(4) := Hexdig(Integer(Peek(X,-3))); -- first 3 bits
Y := Peek(X,3);
for K in 0..11 loop
Genan(17-K) := Hexdig(Integer(Y mod 16));
Y := Y / 16;
end loop;
return Genan;
end Gen_Nan_Form;
W,Di,K: Integer;
begin
if Is_Nan(X) then
if Format="S" or else Format="s" then
if Is_Time_Nan(X) then
return "nant:" & Image(To_time(X),Pltime_Format);
elsif Is_Sym_Nan(X) then
return "nans:" & To_Str(X);
elsif Eq(X,Nan_True) then
return "nan:true";
elsif Eq(X,Nan_False) then
return "nan:false";
elsif Eq(X,Nan_Na) then
return "nan:na";
elsif Eq(X,Nan_Ok) then
return "nan:ok";
elsif Eq(X,Nan_Err) then
return "nan:err";
elsif Eq(X,Nan_Zero) then
return "nan:zero";
else
return Gen_Nan_Form(X);
end if;
else
return Gen_Nan_Form(X);
end if;
else
if Format(Format'First)='F' or else Format(Format'First)='f' then
-- this is something like F10.2
W := 0;
K := 1;
while (Format'First + K <= Format'Last) and then Format(K+Format'First)<='9'
and then Format(K+Format'First)>='0' loop
W := 10 * W + Character'Pos(Format(K+Format'First)) - Character'Pos('0');
K := K+1;
end loop;
if (K+Format'First > Format'Last) or else Format(K+Format'First)/='.' then
raise Wrong_Format;
end if;
K := K+1;
Di := 0;
while (Format'First + K <= Format'Last) and then Format(K+Format'First)<='9'
and then Format(K+Format'First)>='0' loop
Di := 10 * Di + Character'Pos(Format(K+Format'First)) - Character'Pos('0');
K := K+1;
end loop;
if K+Format'First <= Format'Last or else Di>=W-1 then
raise Wrong_Format;
end if;
declare
R: String(1..W);
begin
Numio.Put(R,X, Aft => Di, Exp => 0);
return R;
end;
else
return Num'Image(X);
end if;
end if;
end Img;
function Val(S: String) return Num is
begin
if S(S'First..S'First+2)="nan" then
case S(S'First+3) is
when ':' =>
if S="nan:true" then
return Nan_True;
elsif S="nan:false" then
return Nan_False;
elsif S="nan:na" then
return Nan_Na;
elsif S="nan:ok" then
return Nan_Ok;
elsif S="nan:err" then
return Nan_Err;
elsif S="nan:zero" then
return Nan_Zero;
else
raise Wrong_Nan_Type;
end if;
when 's' =>
return To_Sym_Nan(S(S'First+5..S'Last));
when 't' =>
return To_Time_Nan(Read_Pltime(S(S'First+5..S'Last)));
when others =>
raise Wrong_Nan_Type;
end case;
else
return Num'Value(S);
end if;
end Val;
begin
Init_B40;
Nan_True := To_Nan(16#7_ffff_fff_ff_fff#); -- must be reorganised
Nan_False := To_Nan(16#7_ffff_fff_ff_ffe#);
Nan_OK := To_Nan(16#7_ffff_fff_ff_000#);
Nan_Zero := To_Nan(16#0_0000_000_00_000#);
Nan_NA := To_Nan(16#7_ffff_fff_ff_001#);
Nan_Err := To_Nan(16#7_ffff_fff_ff_800#);
Nan_Err_2 := To_Nan(16#7_ffff_fff_ff_801#);
Nan_Err_2 := To_Nan(16#7_ffff_fff_ff_802#);
end Nan_Payload_64;
with Ada.Text_Io; use Ada.Text_Io;
with Nan_Payload_64; use Nan_Payload_64;
with Ada.Calendar; use Ada.Calendar;
with Gnat.Calendar.Time_Io; use Gnat.Calendar.Time_Io;
procedure Nanpl64test is
R: Long_Float;
procedure Test_Mask_Val(T: Uint64; Tl: Integer; V: Uint64) is
begin
R := Make(T,Tl,V);
if Is_Nan(R) then
Put("made is nan: " & Uint64'Image(T) & "/" & Integer'Image(Tl) & "=" & Uint64'Image(V) & " ### ");
end if;
Put(Uint64'Image(Peek(R,-Tl)));
Put(Uint64'Image(Peek(R,Tl)));
New_Line;
end Test_Mask_Val;
procedure Test_B40(S: String) is
begin
Put(S);
Put(" => ");
Put(B40_To_String(String_To_B40(S)));
New_Line;
end Test_B40;
procedure Test_Sym(S: String) is
begin
Put(S);
Put(" =S=> ");
Put(To_Str(To_Sym_Nan(S)));
New_Line;
end Test_Sym;
procedure Test_Time(T: Time) is
R: Num;
begin
Put(Image(T,Iso_Date));
Put(" =T=> ");
R := To_Time_Nan(T);
Put(">");
Put(Image(To_time(R),Iso_Date));
New_Line;
end Test_Time;
procedure Test_Imgval(S: String) is
begin
Put(S);
Put(" =IV=> ");
Put(Img(Val(S),"s"));
New_Line;
end Test_Imgval;
U: Duration:= -2.0;
begin
R := To_Nan(714);
Put(Payload'Image(Nanval(R)));
if Is_Nan(R) then
Put_Line(" is nan");
end if;
Test_Mask_Val(7,3,712);
Test_Mask_Val(7,5,712);
Test_Mask_Val(7,19,712);
Test_Mask_Val(2#111_1111_1111_1111_1111_1111_1111_11#, 29, 104);
Test_B40("alphalpha");
Test_B40("@123@@");
Test_B40("12 34 44");
Test_B40("000000000");
Test_B40("alabalaportocala");
Test_Sym("alpha");
Test_Time(Clock);
Test_Time(Time_Of(2066,09,02));
Test_Time(Time_Of(1966,09,02));
if To_Time_Nan(Time_Of(2066,09,02)) = To_Time_Nan(Time_Of(2066,09,02)) then
Put_Line("they times are equal");
else
Put_Line("they times are not equal");
end if;
if To_Sym_Nan("ala") = To_Sym_Nan("ala") then
Put_Line("they syms are equal");
else
Put_Line("they syms are not equal");
end if;
if Eq(To_Time_Nan(Time_Of(2066,09,02)), To_Time_Nan(Time_Of(2066,09,02))) then
Put_Line("they times are eq");
else
Put_Line("they times are not eq");
end if;
if Eq(To_Sym_Nan("ala"), To_Sym_Nan("ala")) then
Put_Line("they syms are eq");
else
Put_Line("they syms are not eq");
end if;
Put_Line(Img(To_Sym_Nan("jolly")));
Put_Line(Img(To_Sym_Nan("jolly"),"s"));
Put_Line(Img(To_Time_Nan(Time_Of(2066,09,02)),"s"));
Put_Line(Img(2.33,"F10.3"));
Put_Line(Img(-12.33,"F10.0"));
Put_Line(Img(-2.33,"F10.3"));
Test_Imgval("nans:alpha");
Test_Imgval("nant:2016-09-02/03:10:10.227");
Test_Imgval("nant:2016-09-02/00:05:00.000");
Test_Imgval("nan:ok");
Put_Line(Img(To_Sym_Nan("alph")+To_Sym_Nan("bet"))); -- does it say nans:BET? it is a quiet NaN
end Nanpl64test;